commit a2df2e96e8266ceb343f65bfb394db2577935991 Author: slederer Date: Thu Sep 19 14:10:33 2024 +0200 initial commit diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..e13b46b --- /dev/null +++ b/.gitignore @@ -0,0 +1,34 @@ +pcomp/*.s +progs/*.s +tests/*.s +examples/*.s +*.o +*.exe +*.bin +*.sym +*.swp +*.prog +*.out +*.dis +*.sasmout +*.lib +*.img +*.mem +*.lsym +*.zip +go.sum +sine.pas +graph1.pas +graph2.pas +chase.pas +!runtime.s +**/tridoracpu.*/ +rtl/arty-a7/mig_dram_0/_tmp/* +rtl/arty-a7/mig_dram_0/doc/* +rtl/arty-a7/mig_dram_0/mig_dram_0* +rtl/arty-a7/mig_dram_0/xil_txt.* +rtl/arty-a7/mig_dram_0/*.veo +rtl/arty-a7/mig_dram_0/*.tcl +rtl/arty-a7/mig_dram_0/*.xml +rtl/arty-a7/mig_dram_0/*.v +rtl/arty-a7/mig_dram_0/*.vhdl diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 index 0000000..3755dbb --- /dev/null +++ b/LICENSE.md @@ -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. diff --git a/README.md b/README.md new file mode 100644 index 0000000..e5d2bd7 --- /dev/null +++ b/README.md @@ -0,0 +1,61 @@ +# Tridora System +Tridora is a homebrew CPU written in Verilog and a matching software environment, +including a Pascal compiler and assembler. +Everything was created from the ground up (except soldering stuff). +Everything is as simple as possible while still being reasonably useful. +Everything is open source, so you can read, understand and modify the whole system, hardware and software. + +## Overview +- Homebrew CPU +- Verilog FPGA SoC +- 32-bit word-oriented stack machine architecture +- running at 83 MHz on an Arty-A7 board with four clocks per instruction +- 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 (with two PMODs for microSD cards and VGA output) +- Nexys A7 (not ready yet) + +## 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 diff --git a/doc/irqctrl.md b/doc/irqctrl.md new file mode 100644 index 0000000..580c123 --- /dev/null +++ b/doc/irqctrl.md @@ -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. + diff --git a/doc/mem.md b/doc/mem.md new file mode 100644 index 0000000..10f26c1 --- /dev/null +++ b/doc/mem.md @@ -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 | diff --git a/doc/spisd.md b/doc/spisd.md new file mode 100644 index 0000000..0d04c96 --- /dev/null +++ b/doc/spisd.md @@ -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) + diff --git a/doc/tridoracpu.md b/doc/tridoracpu.md new file mode 100644 index 0000000..118635a --- /dev/null +++ b/doc/tridoracpu.md @@ -0,0 +1,1300 @@ +# Tridora CPU + +Tridora CPU is a softcore CPU written in Verilog. +It is a stack machine design inspired by the J1 CPU and the NOVIX NC4016. +Unlike these CPUs, which are optimized for the Forth programming language, +Tridora CPU has some features intended to support Algol-like programming languages like Pascal. +Essentially, it has specific instructions for accessing local variables on a stack frame. + +## Architecture +The Tridora CPU has no user-accessible general-purpose registers. +It has three stacks: The __evaluation stack__, the __return stack__ and the __user stack__. + +There are three user visible registers: + * FP - Frame Pointer Register + * BP - Base Pointer Register + * RP - Return Stack Pointer Register + +Registers and the evaluation stack elements have a fixed word size, which is currently 32 bits. + +Memory access uses 32-bit words. Addressing still uses byte addresses, so the first memory word is at address 0, the next memory word is at address 4 and so on. There is no support for unaligned memory access or accessing bytes directly. + +All instructions are 16 bits wide. + +### Evaluation Stack +The evaluation stack is used for passing arguments to instructions or subroutines. Most instructions take one or two elements of the evaluation stack and leave the result on the stack. + +The evaluation stack is implemented as internal register file for fast access. The top of the stack is held in an internal register called X. The next-to-the-top stack value is held in an internal register called Y. Instructions can only modify the X register (or memory). The names X and Y are not visible to the programmer. + +The maximum depth of the evaluation stack is implementation-dependent. It should be at least 32 words deep. + +### Return Stack +The return stack stores return addresses from subroutine calls. The RP register points to a memory area. + +### User Stack +The user stack contains stack frames/activation records for higher-level programming languages. It is represented by the FP register. + +## Instruction Format +There are 8 basic instructions which are encoded as bits 15-13 of an instruction word. Some instructions use the rest of the available bits (12-0) as an immediate operand. Some of the basic instructions use additional bits to encode more instructions. + + +The basic instructions are: + +|instruction|description|opcode| +|---|---|---| +|BRANCH|relative branch|000| +|ALU|ALU op|001| +|STORE|store to local memory|010| +|XFER|transfer program control|011| +|LOAD|load from local memory|100| +|CBRANCH|conditional branch|101| +|LOADC|load constant|110| +|EXT|extended instructions|111| + +## Instructions +Note: + * X is the top-of-stack element + * Y is the next-to-top-of-stack-element + * nX is the new top-of-stack-element + +|Instruction|Operand|Description| +|-----------|-------|-----------| +|BRANCH|signed relative 13-bit-offset|unconditional branch| +|ADD|-|nX = X + Y| +|SUB|-|nX = Y - X| +|NOT|-|nX = ~X | +|AND|-|nX = X & Y| +|OR|-|nX = X \| Y| +|XOR|-|nX = X ^ Y| +|CMP|comparison selector|signed compare, leaves 1 on stack if comparison is true, 0 otherwise| +|SHR|-|shift right| +|SHL|-|shift left| +|INC|4-bit unsigned constant|increment, nX = nX + operand| +|DEC|4-bit unsigned constant|decrement| +|CMPU|comparison selector|unsigned compare, leaves 1 on stack if comparison is true, 0 otherwise| +|BPLC|-|byte place| +|BROT|-|byte rotate, rotate left by 8 bits| +|BSEL|-|byte select| +|Y|-|copies Y (next-to-top-of-stack)| +|DUP|-|duplicates top-of-stack| +|NIP|-|removes next-to-top-of-stack element| +|DROP|-|removes top-of-stack element| +|SWAP|-|swap top- and next-to-top-of-stack elements| +|OVER|-|duplicates next-to-top-of-stack element| +|STORE|13-bit unsigned offset|store relative to FP or BP register| +|JUMP|-|jump to value of top-of-stack| +|CALL|-|subroutine call to value of top-of-stack| +|RET|-|return from subroutine| +|LOAD|13-bit-unsigned offset|load relative to FP or BP| +|CBRANCH|13-bit signed offset|conditional branch, branch if top-of-stack is not zero| +|LOADC|13-bit signed constant|load constant with sign-extend| +|LOADI|-|load from memory address contained in X| +|STOREI|4-bit unsigned constant|store X to memory address contained in Y, post-increment address by operand| +|LOADREL|-|load PC relative, load from memory word at an offset to the program counter| +|LOADREG|register spec|load from special register| +|STOREREG|register spec|store X to special register| +|FPADJ|10-bit signed constant|adjust FP register| +### Register Specification +|Spec|Description| +|----|-----------| +|FP | Frame Pointer Register| +|BP | Base Pointer Register | +|RP | Return Stack Pointer | + +### Comparison Selectors +|Sel|Description | Function | +|---|-----------------|----------| +|EQ | equal | X == Y | +|LT | less than | Y < X | +|NE | not equal | X != Y | +|LE | less or equal | Y <= X | +|GE | greater or equal| Y >= X | +|GT | greater than | Y > X | + +## Instruction Reference +### BRANCH +#### Description +Adds a signed 13-bit constant to the program counter. The offset needs to be an even +integer. An offset of 2 sets the PC to the next instruction (i.e. NOP). An offset of 0 is an infinite loop. +#### Instruction format +|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00| +|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- | +|_Value_|0 |0 |0 |x |x |x |x |x |x |x |x |x |x |x |x |x | + + +|Bitfields|Description| +|---------|-----------| +| x | operand | + +#### Examples +An infinite loop, using a label: + + LOOP: BRANCH LOOP + +### ADD +#### Description +nX = X + Y + +Performs an integer addition on the two topmost stack elements. Leaves the result on the stack. + +#### Instruction format +|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00| +|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- | +|_Value_|0 |0 |1 |0 |0 |0 |0 |u |u |X2Y| S | S |x |x |x |x | + + +|Bitfields|Description| +|---------|-----------| +| X2Y | if this bit is set, copy X register to Y (i.e. update stack) | +| S | signed 2-bit field that specifies the stack movement. Can be -1,0 or 1, specified by modifiers SM1,S0,S1| +| u | unused | +| x | operand(unused) | + + +#### Examples +Add the value of local variable at offset 4 and constant 100, replacing the two arguments with the result: + + LOAD 4 + LOADC 100 + ADD + +After this instruction sequence, the stack contains only the result value. + +Add the value of local variable at offset 4 and constant 100, keeping the arguments on the stack and adding the result on top: + + LOAD 4 + LOADC 100 + ADD.S1.X2Y +### SUB +#### Description +nX = Y - X + +Subtracts the next-to-top-of-stack value from the topmost stack element. Leaves the result on the stack. + +#### Instruction format +|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00| +|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- | +|_Value_|0 |0 |1 |0 |0 |0 |1 |u |u |X2Y| S | S |x |x |x |x | + + +|Bitfields|Description| +|---------|-----------| +| X2Y | if this bit is set, copy X register to Y (i.e. update stack) | +| S | signed 2-bit field that specifies the stack movement. Can be -1,0 or 1, specified by modifiers SM1,S0,S1| +| u | unused | +| x | operand(unused) | + + +#### Examples +Subtract the value of local variable at offset 4 from constant 100, replacing the two arguments with the result: + + LOADC 100 + LOAD 4 + SUB + +After this instruction sequence, the stack contains only the result value. + +Subtract the value of local variable at offset 4 from constant 100, keeping the arguments on the stack and adding the result on top: + + LOADC 100 + LOAD 4 + SUB.S1.X2Y + +### NOT +#### Description +nX = ~X + +Inverts all bits of topmost stack element. Stack pointer does not change. + +#### Instruction format +|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00| +|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- | +|_Value_|0 |0 |1 |0 |0 |1 |0 |u |u |X2Y| S | S |x |x |x |x | + + +|Bitfields|Description| +|---------|-----------| +| X2Y | if this bit is set, copy X register to Y (i.e. update stack) | +| S | signed 2-bit field that specifies the stack movement. Can be -1,0 or 1, specified by modifiers SM1,S0,S1| +| u | unused | +| x | operand(unused) | + + +#### Examples + +Invert top-of-stack element: + + LOADC -1 + NOT + +After this instruction sequence, the stack contains value 0. + +### AND +#### Description +nX = X & Y + +Performs a bitwise AND operation on the two topmost stack elements. Leaves the result on the stack. + +#### Instruction format +|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00| +|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- | +|_Value_|0 |0 |1 |0 |0 |1 |1 |u |u |X2Y| S | S |x |x |x |x | + + +|Bitfields|Description| +|---------|-----------| +| X2Y | if this bit is set, copy X register to Y (i.e. update stack) | +| S | signed 2-bit field that specifies the stack movement. Can be -1,0 or 1, specified by modifiers SM1,S0,S1| +| u | unused | +| x | operand(unused) | + + +#### Examples +Perform an AND on local variable at offset 4 and constant $FF (decimal 255), replacing the two arguments with the result: + + LOAD 4 + LOADC $FF + AND + +After this instruction sequence, the stack contains only the result value. + +Isolate bit 3 from local variable at offset 4: + + LOAD 4 + LOADC 8 + AND + +After this instruction sequence, the stack contains 8 or 0, depending on whether bit 3 was set in the local variable. + +### OR +#### Description +nX = X | Y + +Performs a bitwise OR operation on the two topmost stack elements. Leaves the result on the stack. + +#### Instruction format +|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00| +|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- | +|_Value_|0 |0 |1 |0 |1 |0 |0 |u |u |X2Y| S | S |x |x |x |x | + + +|Bitfields|Description| +|---------|-----------| +| X2Y | if this bit is set, copy X register to Y (i.e. update stack) | +| S | signed 2-bit field that specifies the stack movement. Can be -1,0 or 1, specified by modifiers SM1,S0,S1| +| u | unused | +| x | operand(unused) | + + +#### Examples +Perform an OR on local variable at offset 4 and constant 1, replacing the two arguments with the result: + + LOAD 4 + LOADC 1 + OR + +After this instruction sequence, the stack contains only the result value. + +Set bit 3 in value from local variable at offset 4: + + LOAD 4 + LOADC 8 + OR + +After this instruction sequence, the stack contains the value from local variable with bit 3 set. + +### XOR +#### Description +nX = X ^ Y + +Performs a bitwise exclusive or (XOR) operation on the two topmost stack elements. Leaves the result on the stack. + +#### Instruction format +|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00| +|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- | +|_Value_|0 |0 |1 |0 |1 |0 |1 |u |u |X2Y| S | S |x |x |x |x | + + +|Bitfields|Description| +|---------|-----------| +| X2Y | if this bit is set, copy X register to Y (i.e. update stack) | +| S | signed 2-bit field that specifies the stack movement. Can be -1,0 or 1, specified by modifiers SM1,S0,S1| +| u | unused | +| x | operand(unused) | + + +#### Examples +Perform an XOR on local variable at offset 4 and binary constant 1010 (decimal 10), replacing the two arguments with the result: + + LOAD 4 + LOADC %1010 + XOR + +After this instruction sequence, the stack contains only the result value. + +### CMP +#### Description +Compares the two topmost stack elements, using the comparison selector given as operand. +The stack values are assumed to be signed integers. +Leaves 0 on the stack if the comparison is not valid, 1 otherwise. For the operand, there are +several predefined symbols, as shown in the table below. + +For unsigned comparison see the CMPU instruction. + +#### Instruction format +|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00| +|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- | +|_Value_|0 |0 |1 |0 |1 |1 |0 |u |u |X2Y| S | S |0 |ci |ce |cl | + + +|Bitfields|Description| +|---------|-----------| +| X2Y | if this bit is set, copy X register to Y (i.e. update stack) | +| S | signed 2-bit field that specifies the stack movement. Can be -1,0 or 1, specified by modifiers SM1,S0,S1| +| u | unused | +| ci | if 1, invert comparison result | +| ce | if 1, test if X is equal to Y | +| cl | if 1, test if Y is less than X | + +### Comparison Selectors +|Sel|Description | Function | ci|ce|cl| +|---|-----------------|----------|---|--|--| +|EQ | equal | X == Y | 0 | 1| 0| +|LT | less than | Y < X | 0 | 0| 1| +|NE | not equal | X != Y | 1 | 1| 0| +|LE | less or equal | Y <= X | 0 | 1| 1| +|GE | greater or equal| Y >= X | 1 | 0| 1| +|GT | greater than | Y > X | 1 | 1| 1| + +#### Examples +Test if constant -10 is lower than local variable at offset 4, replacing the two arguments with the result: + + LOADC -10 + LOAD 4 + CMP LT + +After this instruction sequence, the stack contains only the result value (0 if the variable was less than -10, 1 otherwise). + +Test if local variable at offset 4 is equal to 12, placing the result on top of the stack: + + LOAD 4 + LOADC 12 + CMP.S1.X2Y EQ + +After this instruction sequence, the stack contains the two arguments and the comparison result (1 if the variable equals 12, 0 otherwise). + +### Y +#### Description +nX = Y + +Gives the value of the next-to-top-of-stack element as result. This instruction is used in combination with the modifiers to +implement the instructions DROP, SWAP and OVER. + +#### Instruction format +|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00| +|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- | +|_Value_|0 |0 |1 |0 |1 |1 |0 |u |u |X2Y| S | S |x |x |x |x | + + +|Bitfields|Description| +|---------|-----------| +| X2Y | if this bit is set, copy X register to Y (i.e. update stack) | +| S | signed 2-bit field that specifies the stack movement. Can be -1,0 or 1, specified by modifiers SM1,S0,S1| +| u | unused | +| x | operand(unused) | + + +#### Examples +See DROP, SWAP and OVER. + + +### DROP +#### Description +Removes the topmost stack element. This is an alias for Y.SM1. + +#### Instruction format +|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00| +|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- | +|_Value_|0 |0 |1 |0 |1 |1 |0 |u |u |X2Y| S | S |x |x |x |x | + + +|Bitfields|Description| +|---------|-----------| +| X2Y | copy X register to Y (i.e. update stack), set to 0 for DROP | +| S | stack movement, SM1,S0 or S1, set to SM1(-1) for DROP| +| u | unused | +| x | operand(unused) | + + +#### Examples + + LOADC 1 + DROP + +After this instruction sequence, the stack is empty. + +### SWAP +#### Description +Swaps the topmost and next to topmost stack elements. This is an alias for Y.S0.X2Y. + +#### Instruction format +|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00| +|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- | +|_Value_|0 |0 |1 |0 |1 |1 |0 |u |u |X2Y| S | S |x |x |x |x | + + +|Bitfields|Description| +|---------|-----------| +| X2Y | copy X register to Y (i.e. update stack), set to 1 for SWAP | +| S | d by modifiers SM1,S0,S1, set to S0(0) for SWAP| +| u | unused | +| x | operand(unused) | + + +#### Examples + + LOADC 1 + LOADC 2 + SWAP + +Before the SWAP instruction, the stack contains (1,2). After the SWAP instruction, the stack contains (2,1). + +### OVER +#### Description +Duplicates the next-to-topmost stack element, adding it on top of the stack. This is an alias for Y.S1.X2Y. + +#### Instruction format +|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00| +|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- | +|_Value_|0 |0 |1 |0 |1 |1 |0 |u |u |X2Y| S | S |x |x |x |x | + + +|Bitfields|Description| +|---------|-----------| +| X2Y | copy X register to Y (i.e. update stack), set to 1 for OVER | +| S | d by modifiers SM1,S0,S1, set to S1(1) for OVER| +| u | unused | +| x | operand(unused) | + + +#### Examples + + LOADC 1 + LOADC 2 + OVER + +Before the OVER instruction, the stack contains (1,2). After the OVER instruction, the stack contains (1,2,1). + +### SHR +#### Description +nX = X >> 1 + +Shift the content of X to the right by one bit. The new most significant bit can either +be 0 (logic shift), or a copy of the previous most significant bit (arithmetic shift). +This is determined by the XT modifier (sign extend). + +#### Instruction format +|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00| +|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- | +|_Value_|0 |0 |1 |1 |0 |0 |0 |u |XT|X2Y| S | S |x |x |x |x | + + +|Bitfields|Description| +|---------|-----------| +| X2Y | if this bit is set, copy X register to Y (i.e. update stack) | +| S | signed 2-bit field that specifies the stack movement. Can be -1,0 or 1, specified by modifiers SM1,S0,S1| +| u | unused | +| XT | if 0, shift in 0, if 1, shift in sign bit | +| x | operand(unused) | + + +#### Examples +Right-shift the value of local variable at offset 4 by 1, shifting in 0: + + LOAD 4 + SHR + +After this instruction sequence, the stack contains the shifted value. +The shifted value replaces the old value on the stack. + +Right-shift with sign-extend, putting the new value on top of the stack, keeping +the old value on the stack: + + LOAD 4 + SHR.S1.X2Y + +After this sequence, the stack contains the original value of the variable and the +shifted value. + +### SHL +#### Description +nX = X << 1 + +Shift the content of X to the left by one bit. The new least significant bit +is set to 0. + +If the operand is set to 2, the content of X is shifted left by two bits instead. +Every other operand value (including zero) where bit 1 is set to zero results in a shift by one bit. + +The assembler treats the operand as optional and, if present, it should be set to 1 or 2. + +#### Instruction format +|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00| +|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- | +|_Value_|0 |0 |1 |1 |0 |0 |1 |u |u |X2Y| S | S |o |o |o |o | + + +|Bitfields|Description| +|---------|-----------| +| X2Y | if this bit is set, copy X register to Y (i.e. update stack) | +| S | signed 2-bit field that specifies the stack movement. Can be -1,0 or 1, specified by modifiers SM1,S0,S1| +| u | unused | +| x | operand | + + +#### Examples +Left-shift the value of local variable at offset 4 by 1, shifting in 0: + + LOAD 4 + SHL + +After this instruction sequence, the stack contains the shifted value. +The shifted value replaces the old value on the stack. + +Left-shift , shifting in 0, putting the new value on top of the stack, keeping +the old value on the stack: + + LOAD 4 + SHL.S1.X2Y + +After this sequence, the stack contains the original value of the variable and the +shifted value. + +Multiply the value of local variable at offset 12 by 4, using a two-bit-shift: + + LOAD 12 + SHL 2 + +After this sequence, the stack contains the shifted value. + +### INC +#### Description +nX = X + operand + +Add a small constant to the topmost stack value. + +#### Instruction format +|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00| +|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- | +|_Value_|0 |0 |1 |1 |0 |0 |1 |u |u |X2Y| S | S |o |o |o |o | + + +|Bitfields|Description| +|---------|-----------| +| X2Y | if this bit is set, copy X register to Y (i.e. update stack) | +| S | signed 2-bit field that specifies the stack movement. Can be -1,0 or 1, specified by modifiers SM1,S0,S1| +| u | unused | +| o | 4-bit unsigned operand | + +#### Examples +Load local variable at offset 4 and increment by 1: + + LOAD 4 + INC 1 + +After this instruction sequence, the stack contains the incremented value. +The incremented value replaces the old value on the stack. + +Load variable and increment by 3, putting the new value on top of the stack, keeping +the old value on the stack: + + LOAD 4 + INC 3 + +After this sequence, the stack contains the original value of the variable and the +incremented value. + +### DEC +#### Description +nX = X - operand + +Substract a small constant from the topmost stack value. + +#### Instruction format +|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00| +|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- | +|_Value_|0 |0 |1 |1 |0 |1 |1 |u |u |X2Y| S | S |o |o |o |o | + + +|Bitfields|Description| +|---------|-----------| +| X2Y | if this bit is set, copy X register to Y (i.e. update stack) | +| S | signed 2-bit field that specifies the stack movement. Can be -1,0 or 1, specified by modifiers SM1,S0,S1| +| u | unused | +| o | 4-bit unsigned operand | + +#### Examples +Load local variable at offset 4 and decrement by 1: + + LOAD 4 + DEC 1 + +After this instruction sequence, the stack contains the decremented value. +The decremented value replaces the old value on the stack. + +Load variable and decrement by 3, putting the new value on top of the stack, keeping +the old value on the stack: + + LOAD 4 + DEC.S1.X2Y 3 + +After this sequence, the stack contains the original value of the variable and the +decremented value. + +### DUP +#### Description +Duplicate the topmost stack element, adding it on top of the stack. This is an alias for INC.S0. + +#### Instruction format +|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00| +|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- | +|_Value_|0 |0 |1 |1 |0 |0 |1 |u |u |X2Y| S | S |o |o |o |o | + + +|Bitfields|Description| +|---------|-----------| +| X2Y | copy X register to Y (i.e. update stack), set to 0 for DUP | +| S | signed 2-bit field that specifies the stack movement, set to S0 (0) for DUP | +| u | unused | +| o | 4-bit unsigned operand, set to 0 for DUP | + +#### Examples + + LOADC 1 + DUP + +After this instruction sequence, the stack contains (1,1). + +### NIP +#### Description +Remove the next-to-topmost stack element. This is an alias for INC.SM1. + +#### Instruction format +|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00| +|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- | +|_Value_|0 |0 |1 |1 |0 |0 |1 |u |u |X2Y| S | S |o |o |o |o | + + +|Bitfields|Description| +|---------|-----------| +| X2Y | copy X register to Y (i.e. update stack), set to 0 for NIP | +| S | signed 2-bit field that specifies the stack movement, set to SM1 (-1) for NIP | +| u | unused | +| o | 4-bit unsigned operand, set to 0 for NIP | + +#### Examples + + LOADC 1 + LOADC 2 + LOADC 3 + NIP + +After this instruction sequence, the stack contains (1,3). + +### BPLC +#### Description +Byte place - place a byte inside a word. The LSB of the topmost stack contains +the byte value. The next-to-top-of-stack element determines the byte position. +The most significant byte is represented by the value 0, the least significant byte +by the value 3. Only bits 0-2 are taken into consideration. + +In other words, a byte address can be used to place a byte from +a 32-bit word. + +All other bytes are set to zero. + +See also BSEL. + +#### Instruction format +|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00| +|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- | +|_Value_|0 |0 |1 |1 |1 |0 |1 |u |u |X2Y| S | S |u |u |u |u | + + +|Bitfields|Description| +|---------|-----------| +| X2Y | if this bit is set, copy X register to Y (i.e. update stack) | +| S | signed 2-bit field that specifies the stack movement. Can be -1,0 or 1, specified by modifiers SM1,S0,S1| +| u | unused | + +#### Examples + +Place the value $42 as the most significant byte in the top-of-stack word: + + LOADC 0 + LOADC $42 + BPLC + +After this instruction sequence, the stack contains the value $42000000. + +Change a byte in an existing word: + + LOADCP AWORD ; addr for STOREI below + DUP ; duplicate addr for LOADI + LOADI ; load original value + LOADC 2 ; load byte position + LOADC $FF ; and byte value + BPLC + NOT ; create mask + AND ; clear byte we want to set + LOADC 2 + LOADC $77 + BPLC ; place byte + OR ; combine with other bytes from original word + STOREI + DROP + AWORD: .WORD $1234ABCD + +After this instruction sequence, the word at AWORD contains the value $123477CD. + +### CMPU +#### Description +Compares the two topmost stack elements, using the comparison selector given as operand. +The stack values are assumed to be unsigned integers. +Leaves 0 on the stack if the comparison is not valid, 1 otherwise. For the operand, there are +several predefined symbols, as shown in the table below. + +For signed comparison see the CMP instruction. + +#### Instruction format +|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00| +|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- | +|_Value_|0 |0 |1 |1 |1 |0 |0 |u |u |X2Y| S | S |0 |ci |ce |cl | + + +|Bitfields|Description| +|---------|-----------| +| X2Y | if this bit is set, copy X register to Y (i.e. update stack) | +| S | signed 2-bit field that specifies the stack movement. Can be -1,0 or 1, specified by modifiers SM1,S0,S1| +| u | unused | +| ci | if 1, invert comparison result | +| ce | if 1, test if X is equal to Y | +| cl | if 1, test if Y is less than X | + +### Comparison Selectors +|Sel|Description | Function | ci|ce|cl| +|---|-----------------|----------|---|--|--| +|EQ | equal | X == Y | 0 | 1| 0| +|LT | less than | Y < X | 0 | 0| 1| +|NE | not equal | X != Y | 1 | 1| 0| +|LE | less or equal | Y <= X | 0 | 1| 1| +|GE | greater or equal| Y >= X | 1 | 0| 1| +|GT | greater than | Y > X | 1 | 1| 1| + +#### Examples +Test if constant 10 is lower than local variable at offset 4, replacing the two arguments with the result: + + LOADC 10 + LOAD 4 + CMPU LT + +After this instruction sequence, the stack contains only the result value (0 if the variable was greater or equal to 10, 1 otherwise). + +Test if local variable at offset 4 is equal to 12, placing the result on top of the stack: + + LOAD 4 + LOADC 12 + CMPU.S1.X2Y EQ + +After this instruction sequence, the stack contains the two arguments and the comparison result (1 if the variable equals 12, 0 otherwise). + +### BROT +#### Description + +Byte rotate - rotate +the topmost stack element left by 8 bits. + +#### Instruction format +|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00| +|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- | +|_Value_|0 |0 |1 |1 |1 |1 |0 |u |u |X2Y| S | S |u |u |u |u | + + +|Bitfields|Description| +|---------|-----------| +| X2Y | if this bit is set, copy X register to Y (i.e. update stack) | +| S | signed 2-bit field that specifies the stack movement. Can be -1,0 or 1, specified by modifiers SM1,S0,S1| +| u | unused | + +#### Examples +Swap high and low half-words: + + LOADCP $1234ABCD + BROT + BROT + +After this instruction sequence, the stack contains the value $ABCD1234. + +### BSEL +#### Description + +Byte select - replace the topmost stack element with a byte value from itself selected +by the value of the next-to-top-of-stack element. The most significant byte is +represented by the value 0, the least significant byte by the value 3. Only the +bits 0-2 of the value are taken into consideration. + +In other words, a byte address can be used to select that byte from +a 32-bit word. + +Bits 8-31 of the result are set to zero. + +#### Instruction format +|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00| +|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- | +|_Value_|0 |0 |1 |1 |1 |1 |1 |u |u |X2Y| S | S |u |u |u |u | + + +|Bitfields|Description| +|---------|-----------| +| X2Y | if this bit is set, copy X register to Y (i.e. update stack) | +| S | signed 2-bit field that specifies the stack movement. Can be -1,0 or 1, specified by modifiers SM1,S0,S1| +| u | unused | + +#### Examples + +Select the most significant byte from the top-of-stack word: + + LOADC 0 + LOADCP $1234ABCD + BSEL + +After this instruction sequence, the stack contains the value $12. + +Load a byte from the address contained in the top-of-stack word: + + LOADCP AWORD+2 + LOADI.S1.X2Y + BSEL + AWORD: .WORD $1234ABCD + +After this instruction sequence, the stack contains the value $AB. +Since bits 0-1 are ignored by the LOADI instruction, the word at the address +AWORD instead of AWORD+2 is placed on the stack. The BSEL instruction looks only at the bits 0-1, +so it selects the corresponding byte specified by the address. + +### STORE +#### Description +Store the value of the topmost stack element into a local variable specified by a 13-bit unsigned constant. +The effective address for the memory transfer is calculated by adding the constant to either the FP register (default) +or the BP register (specified by modifier B). + +#### Instruction format +|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00| +|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- | +|_Value_|0 |1 |0 |o |o |o |o |o |o |o| o | o |o |o |o |B | + + +|Bitfields|Description| +|---------|-----------| +| o | 13-bit unsigned operand (bit 0 is always 0) | +| B | if set to 1, use BP register as base address, else use FP register | + +#### Examples +Store value 0 into local variable at offset 4: + + LOADC 0 + STORE 4 + +Store value 1 into global variable at offset 1024 (assuming the BP register points to global variables): + + LOADC 1 + STORE.B 1024 + +### XFER +#### Description +Transfer program control. Used with several modifiers to implement JUMP, CALL and RET. + +#### Instruction format +|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00| +|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- | +|_Value_|0 |1 |1 |u |u |u |RS |RS |R2P|P2R|S|S|u|u|u|X2P| + + +|Bitfields|Description| +|---------|-----------| +| u | unused | +| RS | 2-bit signed field specifying the return stack movement (-1,0 or 1, modifiers RSM1, RS0, RS1) | +| R2P | set program counter to value from return stack | +| P2R | write program counter value to memory address in return stack pointer| +| S | signed 2-bit field that specifies the stack movement. Can be -1,0 or 1, specified by modifiers SM1,S0,S1| +| X2P | set program counter to X | + +#### Examples +Execute a JUMP instruction: + + LOADC EXIT + JUMP + +Execute a CALL instruction: + + LOADC MYSUBROUTINE + CALL + +Execute a RET instruction: + + EMPTYSUBROUTINE: + RET + + +### JUMP +#### Description +Jump to memory address contained in the topmost stack element. The topmost stack element is removed afterwards. + +Alias for XFER.SM1.X2P. + +#### Instruction format +|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00| +|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- | +|_Value_|0 |1 |1 |u |u |u |RS |RS |R2P|P2R|S|S|u|u|u|X2P| + + +|Bitfields|Description| +|---------|-----------| +| u | unused | +| RS | 2-bit signed field specifying the return stack movement, set to -1 for JUMP | +| R2P | set program counter to value from return stack, set to 0 for JUMP | +| P2R | write program counter value to return stack, set to 0 for JUMP | +| S | signed 2-bit field that specifies the stack movement. Can be -1,0 or 1, specified by modifiers SM1,S0,S1| +| X2P | set program counter to X, set to 1 for JUMP | + +#### Examples +See XFER instruction. + +### CALL +#### Description +Execute a subroutine call. The address of the next instruction is written to memory referenced by the return stack pointer. Then the program counter is set to the value of the topmost stack element, which is removed afterwards. +The return stack pointer is decremented. + +Alias for XFER.RS1.SM1.P2R.X2P. + +#### Instruction format +|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00| +|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- | +|_Value_|0 |1 |1 |u |u |u |RS |RS |R2P|P2R|S|S|u|u|u|X2P| + + +|Bitfields|Description| +|---------|-----------| +| u | unused | +| RS | 2-bit signed field specifying the return stack movement, set to 1 for CALL | +| R2P | set program counter to value from return stack, set to 0 for CALL | +| P2R | write program counter value to return stack, set to 1 for CALL | +| S | signed 2-bit field that specifies the stack movement. Can be -1,0 or 1, specified by modifiers SM1,S0,S1| +| X2P | set program counter to X, set to 0 for CALL | + +#### Examples +See XFER instruction. + +### RET +#### Description +Return from subroutine. The program counter is set to the value read from memory referenced by the return stack pointer. +The return stack pointer is incremented. + +Alias for XFER.RSM1.R2P. + +#### Instruction format +|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00| +|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- | +|_Value_|0 |1 |1 |u |u |u |RS |RS |R2P|P2R|S|S|u|u|u|X2P| + + +|Bitfields|Description| +|---------|-----------| +| u | unused | +| RS | 2-bit signed field specifying the return stack movement, set to -1 for RET | +| R2P | set program counter to value from return stack, set to 1 for RET | +| P2R | write program counter value to return stack, set to 0 for RET | +| S | signed 2-bit field that specifies the stack movement. Can be -1,0 or 1, specified by modifiers SM1,S0,S1| +| X2P | set program counter to X, set to 0 for RET | + +#### Examples +See XFER instruction. + +### CBRANCH +#### Description +Conditional branch. Executes a branch specified by a 13-bit signed constant if the topmost stack element is nonzero. +The topmost stack element is then removed. + +If the modifier Z is used, the branch is executed if the topmost stack element is zero. + +#### Instruction format +|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00| +|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- | +|_Value_|1 |0 |1 |x |x |x |x |x |x |x |x |x |x |x |x |N | + + +|Bitfields|Description| +|---------|-----------| +| x | operand | +| N | if 1 (default), branch if X if nonzero, if 0 (modifier Z), branch if X is zero | + +#### Examples +Branch if local variable at offset 4 is nonzero: + + LOAD 4 + CBRANCH CONTINUE + RET + CONTINUE: + ... + +Branch if local variables at offset 4 and 16 are both zero: + + LOAD 4 + LOAD 16 + OR + CBRANCH.Z EXIT + ... + EXIT: + RET + +### LOAD +#### Description +Load the value a local variable specified by a 13-bit unsigned constant onto the stack. +The effective address for the memory transfer is calculated by adding the constant to either the FP register (default) +or the BP register (specified by modifier B). + +#### Instruction format +|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00| +|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- | +|_Value_|1 |0 |0 |o |o |o |o |o |o |o| o | o |o |o |o |B | + + +|Bitfields|Description| +|---------|-----------| +| o | 13-bit unsigned operand (bit 0 is always 0) | +| B | if set to 1, use BP register as base address, else use FP register | + +#### Examples +Load local variable at offset 4: + + LOAD 4 + +Load global variable at offset 1024 (assuming the BP register points to global variables): + + LOAD.B 1024 + +### LOADC +#### Description +Load a 13-bit signed constant onto the stack. + +#### Instruction format +|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00| +|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- | +|_Value_|1 |1 |0 |o |o |o |o |o |o |o| o | o |o |o |o |o | + + +|Bitfields|Description| +|---------|-----------| +| o | 13-bit signed operand | + +#### Examples +Load constants 1,2,-4000 onto the stack: + + LOADC 1 + LOADC 2 + LOADC -4000 + +### LOADI +#### Description + +Load from memory address contained in the topmost stack element. The topmost stack element is replaced by the value read from memory. + +#### Instruction format +|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00| +|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- | +|_Value_|1 |1 |1 |0 |0 |1 |W |u |u |X2Y|S|S|o |o |o |o | + + +|Bitfields|Description| +|---------|-----------| +| W | perform memory write, set to 0 for LOADI | +| X2Y | copy X register to Y (i.e. update stack) | +| S | signed 2-bit field that specifies the stack movement. Can be -1,0 or 1, specified by modifiers SM1,S0,S1| +| o | 4 bit unsigned operand, unused for LOADI | +#### Examples +Take pointer from local variable at offset 4 and load from that address: + + LOAD 4 + LOADI + +### STOREI +#### Description + +Store value from the topmost stack element at memory address contained in next-to-topmost stack element. Removes two elements from the stack and puts the address back on top, incremented by a small constant (which may be zero). + +#### Instruction format +|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00| +|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- | +|_Value_|1 |1 |1 |0 |0 |1 |W |u |u |X2Y|S|S|o |o |o |o | + + +|Bitfields|Description| +|---------|-----------| +| W | perform memory write, set to 1 for STOREI | +| X2Y | copy X register to Y (i.e. update stack) | +| S | signed 2-bit field that specifies the stack movement. Can be -1,0 or 1, specified by modifiers SM1,S0,S1| +| o | 4 bit unsigned operand | +#### Examples +Take pointer from local variable at offset 4 and store the constant value 11 at that address: + + LOAD 4 + LOADC 11 + STOREI + DROP + +After this instruction sequence, the stack is empty. + +Store constant value 42 with post-increment (pointer is at local variable offset 4): + + LOAD 4 + LOADC 42 + STOREI 4 + +After this instruction sequence, the stack contains the pointer value incremented by 4. + +### LOADREG +#### Description + +Load content of a register onto the stack. + +#### Instruction format +|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00| +|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- | +|_Value_|1 |1 |1 |0 |0 |0 |W |u |u |u |u |u |o |o |o |o | + + +|Bitfields|Description| +|---------|-----------| +| W | if set to 1, write to register, else read from register (0 for LOADREG)| +| u | unused | +| o | register specification | + +#### Register Specification +|Spec|Description|operand field| +|----|-----------|-------------| +|FP | Frame Pointer Register|0000| +|BP | Base Pointer Register |0001| +|RP | Return Stack Pointer |0010| + +#### Examples +Get content of BP register: + + LOADREG BP + +### STOREREG +#### Description + +Set register to value of the topmost stack element, which is removed afterwards. + +#### Instruction format +|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00| +|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- | +|_Value_|1 |1 |1 |0 |0 |0 |W |u |u |u |u |u |o |o |o |o | + + +|Bitfields|Description| +|---------|-----------| +| W | if set to 1, write to register, else read from register (1 for STOREREG)| +| u | unused | +| o | register specification | + +#### Register Specification +|Spec|Description|operand field| +|----|-----------|-------------| +|FP | Frame Pointer Register|0000| +|BP | Base Pointer Register |0001| +|RP | Return Stack Pointer |0010| + +#### Examples +Set BP register to 2000 (hexadecimal): + + LOADCP $2000 + STOREREG BP + +### LOADREL +#### Description + +Load PC relative: Load a word-sized value from the address calculated by adding an unsigned offset to the program counter. + +The assembler supports a pseudo-instruction LOADCP (load from constant pool) that automatically places values into a constant pool +which then can be used with the LOADREL instruction. A constant pool is automatically placed at the end of a program. Additional +constant pools can be created anywhere with the .CPOOL directive. Since the offset to LOADREL can be at most 1022, more than one +constant pool is required when the code size exceeds 1022 bytes. + +#### Instruction format +|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00| +|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- | +|_Value_|1 |1 |1 |1 |0 |1 |o |o |o |o |o |o |o |o |o |o | + + +|Bitfields|Description| +|---------|-----------| +| o | unsigned 10-bit offset to the program counter | + +#### Examples +Load a large constant: + + LOADCP 30000 + +### LOADCP +#### Description + +Load from constant pool: A pseudo-instruction to make using the LOADREL instruction easier. See the LOADREL instruction. + + +### FPADJ +#### Description + +Adjust frame pointer. Add a signed 10-bit constant to the FP register. Used to adjust the user stack +when entering or leaving a subroutine. + +#### Instruction format +|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00| +|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- | +|_Value_|1 |1 |1 |0 |1 |1 |o |o |o |o |o |o |o |o |o |o | + + +|Bitfields|Description| +|---------|-----------| +| o | 10-bit signed operand | + +#### Examples +Make room for 32 bytes of local variables when entering a procedure: + + MYPROC: + FPADJ -32 + ... + +Move frame pointer back by 32 bytes when leaving the procedure: + + MYPROC: + ... + FPADJ 32 + RET + + diff --git a/doc/vga.md b/doc/vga.md new file mode 100644 index 0000000..25b9cdd --- /dev/null +++ b/doc/vga.md @@ -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. diff --git a/examples/3dcube.pas b/examples/3dcube.pas new file mode 100644 index 0000000..7ba40e2 --- /dev/null +++ b/examples/3dcube.pas @@ -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. diff --git a/examples/LICENSES.md b/examples/LICENSES.md new file mode 100644 index 0000000..8992b88 --- /dev/null +++ b/examples/LICENSES.md @@ -0,0 +1,10 @@ +# rtpair.pas +originally from [https://github.com/Postrediori/Pascal-Raytracer](https://github.com/Postrediori/Pascal-Raytracer), no license specified there +# 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 , via Wikimedia Commons +https://commons.wikimedia.org/wiki/File:Snow_leopard_portrait.jpg +* shinkansen.pict: 投稿者が撮影, CC BY-SA 3.0 , via Wikimedia Commons + https://commons.wikimedia.org/wiki/File:0key22-86.JPG + diff --git a/examples/ara.pict b/examples/ara.pict new file mode 100644 index 0000000..7322add Binary files /dev/null and b/examples/ara.pict differ diff --git a/examples/conway.pas b/examples/conway.pas new file mode 100644 index 0000000..f490b0e --- /dev/null +++ b/examples/conway.pas @@ -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. diff --git a/examples/hellop.pas b/examples/hellop.pas new file mode 100644 index 0000000..ad18ffd --- /dev/null +++ b/examples/hellop.pas @@ -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. } diff --git a/examples/lines.pas b/examples/lines.pas new file mode 100644 index 0000000..d1cdf58 --- /dev/null +++ b/examples/lines.pas @@ -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. diff --git a/examples/mandelbrot.pas b/examples/mandelbrot.pas new file mode 100644 index 0000000..8f27c73 --- /dev/null +++ b/examples/mandelbrot.pas @@ -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. diff --git a/examples/rtpair.pas b/examples/rtpair.pas new file mode 100644 index 0000000..873af41 --- /dev/null +++ b/examples/rtpair.pas @@ -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 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. diff --git a/lib/corelib.s b/lib/corelib.s new file mode 100644 index 0000000..57f35a8 --- /dev/null +++ b/lib/corelib.s @@ -0,0 +1,1501 @@ +; Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details + + .EQU CR 13 + .EQU LF 10 + .EQU UART_REG 2048 + .EQU IRQC_REG 2432 + + .EQU PROG_START 24576 + .EQU FP_START 24060 + .EQU RP_START 24064 +NEWLINE: + LOADC CR + LOADCP CONOUT + CALL + LOADC LF + LOADCP CONOUT + CALL + RET + +; print string of byte characters +; takes pointer to string on eval stack +PRINTLINE: + DUP ; duplicate address as arg to printchar + LOADCP _PRINTCHAR + CALL + CBRANCH.Z PRINTLINE_EXIT ; if char is zero, exit + INC 1 ; increment address + BRANCH PRINTLINE +PRINTLINE_EXIT: + DROP ; remove address from stack + RET + +; print a single character +; takes a byte pointer on eval stack +; returns character on eval stack +_PRINTCHAR: + LOADI.S1.X2Y ; load word, keep address on stack + BSEL ; select byte of a word via address + DUP ; check for null byte + CBRANCH.Z _PRINTCHAR_XT + DUP + LOADCP CONOUT + CALL +_PRINTCHAR_XT: + RET + +; print a 32-bit hexadecimal number +; takes the value on the stack +PRINTHEXW: + BROT + DUP + LOADCP _PRINTHEXB + CALL + BROT + DUP + LOADCP _PRINTHEXB + CALL + BROT + DUP + LOADCP _PRINTHEXB + CALL + BROT + LOADCP _PRINTHEXB + CALL + RET + +_PRINTHEXB: + DUP + SHR + SHR + SHR + SHR + LOADCP _PRINTNIBBLE + CALL + LOADCP _PRINTNIBBLE + CALL + RET + +_PRINTNIBBLE: + LOADC 15 ; isolate nibble + AND + LOADC 10 + CMPU.S0 GE ; nibble >= 10 ? + CBRANCH.NZ _PRINTNIBBLE_1 ; then print a-f + LOADC '0' ; else print 0-9 + BRANCH _PRINTNIBBLE_2 +_PRINTNIBBLE_1: + LOADC 55 ; 55 + 10 == 'A' +_PRINTNIBBLE_2: + ADD + LOADCP CONOUT + CALL + RET + +_MUL10: + SHL ; x * 2 + DUP + SHL 2 ; x * 8 + ADD ; x * 2 + x * 8 = x * 10 + RET + +; shift left multiple times +; parameters: value, count +; returns: shifted value +_SHLM: + DUP + CBRANCH.Z _SHLM_X ; if count is zero, exit + LOADC 8 + CMPU.S0 LT ; count is less than 8? + CBRANCH _SHLM_1 + ; if >= 8, continue here + DEC 8 ; decrement counter by 8 + SWAP ; swap counter and value + BROT ; byte rotate value + LOADCP $FFFFFF00 ; and mask the lowest 8 bits + AND ; to get a shift left by 8 + SWAP ; swap back counter and value + BRANCH _SHLM +_SHLM_1: + DEC 1 + SWAP + SHL + SWAP + BRANCH _SHLM +_SHLM_X: + DROP ; drop counter + RET + +; shift right multiple times +; parameters: value, count +; returns: shifted value +_SHRM: + DUP + CBRANCH.Z _SHRM_X ; if count is zero, exit + DEC 1 + SWAP + SHR + SWAP + BRANCH _SHRM +_SHRM_X: + DROP ; remove counter + RET + + +; --- print signed integer as decimal +; parameter: value +PRINTDEC: + DUP + LOADC 0 + CMP GE + CBRANCH PRINTDECU + LOADC '-' + LOADCP CONOUT + CALL + NOT + INC 1 ; negate value + ; fallthrough to PRINTDECU + +; print unsigned integer as decimal +; parameter: value +; local vars: +; 0: current value +; 4: pointer to digit value table +; 8: digit counter +; 12: flag for leading zeroes +PRINTDECU: + FPADJ -16 + STORE 0 + LOADCP CONVDEC_TAB + STORE 4 + LOADC 0 + STORE 12 +PRDEC_NEXTDIGIT: + LOADC 0 + STORE 8 + LOAD 4 + LOADI ; load via pointer + CBRANCH.Z PRDECU_DONE ; if digit value is 0, we are done +DIGIT_LOOP: + LOAD 4 + LOADI + LOAD 0 + CMPU GT + CBRANCH DIGIT_DONE + LOAD 0 + LOAD 4 + LOADI + SUB + STORE 0 + LOAD 8 + INC 1 + STORE 8 + BRANCH DIGIT_LOOP +DIGIT_DONE: + LOAD 8 + CBRANCH.NZ DIGIT_OUT ; if digit is not 0, print it + LOAD 12 ; is it a leading zero, ignore it + CBRANCH.Z DIGIT_NEXT +DIGIT_OUT: + LOADC 1 ; set leading zero flag + STORE 12 + LOAD 8 + LOADCP _PRINTDIGIT + CALL +DIGIT_NEXT: + LOAD 4 ; increment digit value pointer + INC 4 + STORE 4 + BRANCH PRDEC_NEXTDIGIT +PRDECU_DONE: + LOAD 0 + LOADCP _PRINTDIGIT + CALL + FPADJ 16 + RET + +_PRINTDIGIT: + LOADC '0' + ADD + LOADCP CONOUT + CALL + RET +CONVDEC_TAB: + .WORD 1000000000,100000000,10000000,1000000,100000,10000,1000,100,10,0 + +; ------ read a 8-digit hexadecimal number from the console +; stores variables on the user stack, so the FP register must be +; inizialized. +; returns two values on the eval stack: +; - return code (topmost) +; 0 - no valid number +; 1 - valid number +; 2 - valid number and enter was pressed +; - result value +_READHEX: + FPADJ -8 + LOADC 0 ; current value + STORE 0 + LOADC 8 ; max number of digits + STORE 4 ; remaining digits counter +_READHEX_1: + LOADCP CONIN + CALL + LOADC CR ; RETURN pressed? + CMP.S0 EQ + CBRANCH _READHEX_RT + DUP + LOADCP CONOUT ; echo character + CALL + LOADCP _CONVHEXDIGIT + CALL + LOADC -1 + CMP.S0 EQ ; invalid character? + CBRANCH.NZ _READHEX_XT + LOAD 0 + SHL 1 ; shift previous nibble + SHL 1 + SHL 1 + SHL 1 + OR ; combine with last digit + STORE 0 + LOAD 4 + DEC 1 + DUP + STORE 4 + CBRANCH.NZ _READHEX_1 + BRANCH _READHEX_XT1 +_READHEX_RT: ; if no digits were entered, set return code + DROP ; drop read character + LOAD 4 ;remaining digits counter + LOADC 8 + CMP NE + CBRANCH _READHEX_RT2 + LOADC 0 ; no valid input + BRANCH _READHEX_XT3 +_READHEX_RT2: + LOADC 2 ; valid input and return pressed + BRANCH _READHEX_XT3 +_READHEX_XT: + DROP + LOAD 4 + LOADC 8 + CMP EQ ; if no digits were entered + CBRANCH _READHEX_XT0 +_READHEX_XT1: + LOADC 1 ; valid input flag + BRANCH _READHEX_XT3 +_READHEX_XT0: + LOADC 0 +_READHEX_XT3: + LOAD 0 + SWAP + FPADJ 8 + RET + +; ------ convert character on the eval stack to upper case +UPCASE: + LOADC 'a' + CMP.S0 LT + CBRANCH UPCASE_XT + LOADC 'z' + CMP.S0 GT + CBRANCH UPCASE_XT + LOADC 32 + SUB +UPCASE_XT: + RET + +; ------ convert hexadecimal digit to integer +; ------ takes an ascii character as parameter on the eval stack +; ------ returns an integer value from 0-15 on the eval stack, +; ------ or -1 if the character was not a valid hexadecimal digit +_CONVHEXDIGIT: + LOADCP UPCASE + CALL + LOADC '0' + CMP.S0 LT ; character < '0'? + CBRANCH.NZ _CONVHEXDIGIT_ERR + LOADC '9' + CMP.S0 GT ; character > '9'? + CBRANCH.NZ _CONVHEXDIGIT_ISALPHA + LOADC '0' ; character is between '0' and '9', subtract '0' + SUB + BRANCH _CONVHEXDIGIT_NBL +_CONVHEXDIGIT_ISALPHA: + LOADC 'A' + CMP.S0 LT ; character < 'A'? + CBRANCH.NZ _CONVHEXDIGIT_ERR + LOADC 'F' + CMP.S0 GT ; character > 'F'? + CBRANCH.NZ _CONVHEXDIGIT_ERR + LOADC 55 ; character is between 'A' and 'F', subtract ('A' - 10) + SUB +_CONVHEXDIGIT_NBL: + RET +_CONVHEXDIGIT_ERR: + DROP ; remove character from stack + LOADC -1 ; error + RET + +; --------- output a character on serial console +; --------- takes a character (as the lsb of a word) on the eval stack +CONOUT: + LOADC UART_REG ; address of UART register + LOADI ; load status + LOADC 256 ; check bit 8 (tx_busy) + AND + CBRANCH.NZ CONOUT ; loop if bit 8 is not zero + + ; transmitter is idle now, write character + LOADC 1024 ; TX enable bit + OR + LOADC UART_REG ; I/O address + SWAP ; swap addr and value as args for STOREI + STOREI + DROP + RET + +; ---------- check if a character has been received +; returns: 1 if a character has been received, 0 otherwise +CONAVAIL: + LOADC 0 ; preliminary result + LOADC UART_REG ; address of UART register + LOADI ; load status + LOADC 512 ; check bit 9 (rx_avail) + AND + CBRANCH.Z CONAVAIL_0 ; if bit is zero, we are done + INC 1 ; add 1 to preliminary result +CONAVAIL_0: + RET + +; ---------- wait until a character is received and return it on eval stack +CONIN: + LOADC UART_REG ; address of UART register + LOADI ; load status + LOADC 512 ; check bit 9 (rx_avail) + AND + CBRANCH.Z CONIN ; loop if bit 9 is zero + LOADC UART_REG + LOADI ; read register again + LOADC 255 ; mask status bits + AND + LOADC UART_REG ; I/O address + LOADC 512 ; set bit 9 (rx_clear) + STOREI ; write register + DROP + RET + +; return absolute value +; parameters: value +; returns: abs(value) +ABS: + LOADC 0 + CMP.S0 GE + CBRANCH ABS_XT + DEC 1 ; negate + NOT +ABS_XT: + RET + +; signed multiplication +_MUL: + ; fallthrough to MULU + +; unsigned multiplication: x * y +; parameters: [x, y] +; returns: x * y +_MULU: + FPADJ -16 + STORE 0 ; x + STORE 4 ; y + LOADC 32 + STORE 8 ; bit count + LOADC 0 + STORE 12 ; result +MULU_LOOP: + LOAD 8 + CBRANCH.Z MULU_XT ; if count is zero, exit + LOAD 0 + LOADC 1 + AND.S0 ; get bit 0 + CBRANCH.Z MULU_1 ; if bit 0 is zero, next binary digit + LOAD 12 + LOAD 4 + ADD ; result = result + y + STORE 12 +MULU_1: + SHR ; x = x >> 1 + STORE 0 + LOAD 4 + SHL ; y = y << 1 + STORE 4 + LOAD 8 + DEC 1 ; count = count -1 + STORE 8 + BRANCH MULU_LOOP +MULU_XT: + LOAD 12 + FPADJ 16 + RET + +; signed integer division +; parameters: [x,y] +; result: x/y +_DIV: + FPADJ -4 + LOADC 0 + STORE 0 ; clear negate flag + DUP + LOADC 0 + CMP GE ; is y positive? + CBRANCH DIV_ISPOS + ; y is negative + NOT + INC 1 ; negate y + LOADC -1 + STORE 0 ; set negate flag +DIV_ISPOS: + SWAP ; swap x and y + DUP + LOADC 0 + CMP GE ; is x positive? + CBRANCH DIV_ISPOS2 + ; x is negative + NOT + INC 1 ; negate x + LOAD 0 + NOT ; invert negate flag + STORE 0 +DIV_ISPOS2: + SWAP ; swap back y and x + LOADCP _DIVMODU + CALL + DROP ; throw away remainder + LOAD 0 + CBRANCH.Z DIV_XT ; negate flag set? + NOT + INC 1 ; negate value +DIV_XT: + FPADJ 4 + RET + +; signed integer modulo +; the result is negative if x is negative. +; the sign of y is ignored. +; parameters: [x,y] +; returns: remainder of x/y +_MOD: + FPADJ -4 + LOADC 0 + STORE 0 ; clear negate flag + DUP + LOADC 0 + CMP GE ; is y positive? + CBRANCH MOD_ISPOS + ; y is negative + NOT + INC 1 ; negate y +MOD_ISPOS: + SWAP ; swap x and y + DUP + LOADC 0 + CMP GE ; is x positive? + CBRANCH MOD_ISPOS2 + ; x is negative + NOT + INC 1 ; negate x + LOAD 0 + NOT ; invert negate flag + STORE 0 +MOD_ISPOS2: + SWAP ; swap back y and x + LOADCP _DIVMODU + CALL + NIP ; throw away quotient + LOAD 0 + CBRANCH.Z MOD_XT ; negate flag set? + NOT + INC 1 ; negate value +MOD_XT: + + FPADJ 4 + RET + +; unsigned integer division +; parameters: [x,y] +; result: x/y +_DIVU: + LOADCP _DIVMODU ; just call DIVMODU and throw away the remainder + CALL + DROP + RET + +; unsigned integer division with remainder +; parameters: [x,y] +; result: [ quotient, remainder ] +_DIVMODU: + FPADJ -20 + STORE 0 ; y + STORE 4 ; x + LOADC 32 + STORE 8 ; bit count + LOADC 0 + STORE 12 ; tmp value + LOADC 0 + STORE 16 ; result +DIVU_LOOP: + LOAD 8 + CBRANCH.Z DIVU_END ; if count is zero, exit + LOAD 16 + SHL ; result = result << 1 + STORE 16 + LOAD 12 + SHL ; tmp << 1 + LOAD 4 + LOADCP $80000000 ; msb of x + AND + CBRANCH.Z DIVU_1 + INC 1 ; tmp[0] is 0, so +1 means tmp[0] = 1 +DIVU_1: + DUP + STORE 12 ; tmp = tmp << 1 | msb + LOAD 0 + CMPU GE ; tmp >= y? + CBRANCH.Z DIVU_2 + LOAD 16 + INC 1 ; result = result | 1 + STORE 16 + LOAD 12 + LOAD 0 + SUB + STORE 12 ; tmp = tmp - y +DIVU_2: + LOAD 4 + SHL + STORE 4 + LOAD 8 + DEC 1 + STORE 8 + BRANCH DIVU_LOOP +DIVU_END: + LOAD 16 ; result (quotient) + LOAD 12 ; remainder + FPADJ 20 + RET + + .CPOOL + +; wait approx. 1 millisecond +; +; 83.333 MHz Clock, three instructions a 4 cycles +; 83333 / 12 = 6944.4166 +; works only if executed without wait states (i.e. +; from BRAM/SRAM) +WAIT1MSEC: + LOADCP 6944 +WAIT1LOOP: + DEC 1 + DUP + CBRANCH.NZ WAIT1LOOP + DROP + RET + +; clear a memory block +; parameters: addr, length in bytes +; length must be multiple of wordsize. +; if it is not, the last (partial) word is not cleared. +_CLEARMEM: + SHR + SHR ; calculate length in words + +CLEARMEM_L: + DUP + CBRANCH.Z CLEARMEM_X ; if zero words to do, exit + SWAP ; swap counter and addr + LOADC 0 + STOREI 4 ; store with post-increment + SWAP ; swap counter and addr back + DEC 1 ; decrement counter + BRANCH CLEARMEM_L +CLEARMEM_X: + DROP + DROP + RET + +; copy a number of words from source to destination +; parameters: [ dest, source, count ] +; source and destination may not overlap + .EQU COPYWORDS_COUNT 0 + .EQU COPYWORDS_SRC 4 + .EQU COPYWORDS_DEST 8 +_COPYWORDS: + FPADJ -12 + STORE COPYWORDS_COUNT ; store args to local vars + STORE COPYWORDS_SRC + STORE COPYWORDS_DEST + LOAD COPYWORDS_COUNT ; we will keep count on the stack inside the loop +COPYWORDS_L0: + DUP ; count is on tos, duplicate it + CBRANCH.Z COPYWORDS_XT ; check if count is zero + DEC 1 ; if not, decrement + LOAD COPYWORDS_DEST ; load dest addr for STOREI below + LOAD COPYWORDS_SRC ; load src addr + INC.S1.X2Y 4 ; increment by 4 and put as new value on tos + STORE COPYWORDS_SRC ; store again, old addr is now on tos + LOADI ; load value by old addr + STOREI 4 ; store value and post-increment + STORE COPYWORDS_DEST ; store post-incremented addr + BRANCH COPYWORDS_L0 +COPYWORDS_XT: + DROP ; drop count value + FPADJ 12 + RET + +; compare a number of words +; parameters: [ dest, source, count ] +; returns: 1 if all words are equal, 0 otherwise + .EQU CMPWORDS_COUNT 0 + .EQU CMPWORDS_SRC 4 + .EQU CMPWORDS_DEST 8 +_CMPWORDS: + FPADJ -12 + STORE CMPWORDS_COUNT ; store args to local vars + STORE CMPWORDS_SRC + STORE CMPWORDS_DEST + LOAD CMPWORDS_COUNT +CMPWORDS_L0: + DUP ; count is on tos, duplicate it + CBRANCH.Z CMPWORDS_XT ; check if count is zero + DEC 1 ; if not, decrement + LOAD CMPWORDS_SRC ; load src addr + INC.S1.X2Y 4 ; increment by 4 and put as new value on tos + STORE CMPWORDS_SRC ; store again, old addr is now on tos + LOADI ; load src value + LOAD CMPWORDS_DEST ; load dest addr + INC.S1.X2Y 4 ; increment by 4 and put as new value on tos + STORE CMPWORDS_DEST ; store again, old addr is now on tos + LOADI ; load dest value + CMPU EQ + CBRANCH CMPWORDS_L0 ; if words are equal, continue loop + DROP ; drop count value + LOADC 0 ; load exit code 0 + BRANCH CMPWORDS_XT2 +CMPWORDS_XT: + DROP ; drop count value + LOADC 1 ; load exit code 1 +CMPWORDS_XT2: + FPADJ 12 + RET + + .CPOOL +; --------- Graphics Library --------------- + ; vga controller registers + .EQU FB_RA $900 + .EQU FB_WA $901 + .EQU FB_IO $902 + .EQU FB_PS $903 + .EQU FB_PD $904 + .EQU FB_CTL $905 +; set a pixel in fb memory +; parameters: x,y - coordinates +PUTPIXEL_1BPP: + ; calculate vmem address: + OVER ; duplicate x + ; divide x by 32 + SHR + SHR + SHR + SHR + SHR + SWAP + ; multiply y by words per line + SHL 2 + SHL 2 + SHL + + ADD ; add results together for vmem addr + + DUP + LOADCP FB_WA + SWAP + STOREI ; store to framebuffer write addr register + DROP + LOADCP FB_RA ; and to framebuffer read addr register + SWAP + STOREI + DROP + + ; x is now at top of stack + ; get bit value from x modulo 32 + LOADC 31 + AND + SHL 2 ; (x & 31) * 4 = offset into table + LOADCP INT_TO_PIX_TABLE + ADD + LOADI + + LOADCP FB_IO + ; read old vmem value + LOADCP FB_IO + LOADI + ; or in new bit + OR + ; write new value + STOREI + DROP + + RET + +INT_TO_PIX_TABLE: + .WORD %10000000_00000000_00000000_00000000 + .WORD %01000000_00000000_00000000_00000000 + .WORD %00100000_00000000_00000000_00000000 + .WORD %00010000_00000000_00000000_00000000 + .WORD %00001000_00000000_00000000_00000000 + .WORD %00000100_00000000_00000000_00000000 + .WORD %00000010_00000000_00000000_00000000 + .WORD %00000001_00000000_00000000_00000000 + .WORD %00000000_10000000_00000000_00000000 + .WORD %00000000_01000000_00000000_00000000 + .WORD %00000000_00100000_00000000_00000000 + .WORD %00000000_00010000_00000000_00000000 + .WORD %00000000_00001000_00000000_00000000 + .WORD %00000000_00000100_00000000_00000000 + .WORD %00000000_00000010_00000000_00000000 + .WORD %00000000_00000001_00000000_00000000 + .WORD %00000000_00000000_10000000_00000000 + .WORD %00000000_00000000_01000000_00000000 + .WORD %00000000_00000000_00100000_00000000 + .WORD %00000000_00000000_00010000_00000000 + .WORD %00000000_00000000_00001000_00000000 + .WORD %00000000_00000000_00000100_00000000 + .WORD %00000000_00000000_00000010_00000000 + .WORD %00000000_00000000_00000001_00000000 + .WORD %00000000_00000000_00000000_10000000 + .WORD %00000000_00000000_00000000_01000000 + .WORD %00000000_00000000_00000000_00100000 + .WORD %00000000_00000000_00000000_00010000 + .WORD %00000000_00000000_00000000_00001000 + .WORD %00000000_00000000_00000000_00000100 + .WORD %00000000_00000000_00000000_00000010 + .WORD %00000000_00000000_00000000_00000001 + +PUTMPIXEL: + LOADC 1 +; set a pixel in fb memory +; parameters: x,y,color - coordinates, color value (0-15) +PUTPIXEL: +PUTPIXEL_4BPP: + .EQU PUTPIXEL_X 0 + .EQU PUTPIXEL_Y 4 + .EQU PUTPIXEL_COLOR 8 + .EQU PUTPIXEL_PIXPOS 12 + .EQU PUTPIXEL_FS 16 + + FPADJ -PUTPIXEL_FS + + STORE PUTPIXEL_COLOR + STORE PUTPIXEL_Y + STORE PUTPIXEL_X + + + ; calculate vmem address: (x / 8) + (y * 80) + LOAD PUTPIXEL_X + ; divide x by 8 + SHR + SHR + SHR + + LOAD PUTPIXEL_Y + ; multiply y by words per line + SHL 2 + SHL 2 ; * 16 + DUP + SHL 2; * 64 + ADD ; x*16 + x*64 + + ADD ; add results together for vmem addr + + LOADCP FB_WA + OVER + STOREI ; store to framebuffer write addr register + DROP + LOADCP FB_RA ; and to framebuffer read addr register + SWAP ; swap addr and value for STOREI + STOREI + DROP + + LOAD PUTPIXEL_X + ; |0000.0000|0000.0000|0000.0000|0000.1111| + LOADC 7 + AND ; calculate pixel position in word + LOADC 7 + SWAP + SUB ; pixpos = 7 - (x & 7) + STORE PUTPIXEL_PIXPOS + + LOAD PUTPIXEL_COLOR + LOAD PUTPIXEL_PIXPOS + SHR ; rcount = pixpos / 2 +ROTLOOP_: + DUP ; exit loop if rcount is 0 + CBRANCH.Z ROTLOOP_END + SWAP ; pixel value is now on top of stack + BROT ; value = value << 8 + SWAP ; rcount is now on top of stack + DEC 1 ; rcount = rcount - 1 + BRANCH ROTLOOP_ +ROTLOOP_END: + DROP ; drop rcount + ; shifted pixel value is now at top of stack + LOAD PUTPIXEL_PIXPOS + LOADC 1 + AND + CBRANCH.Z EVEN_PIXPOS + SHL 2 ; if pixpos is odd, shift by 4 bits + SHL 2 +EVEN_PIXPOS: + LOAD PUTPIXEL_X + ; get bit value from x modulo 8 + LOADC 7 + AND + SHL 2 ; (x & 7) * 4 = offset into table + LOADCP INT_TO_MASK_TABLE + ADD + LOADI + + ; read old vmem value + LOADCP FB_IO + LOADI + ; mask bits + AND + ; or in shifted pixel value + OR + + ; write new value + LOADCP FB_IO + SWAP + STOREI + DROP + + FPADJ PUTPIXEL_FS + RET + + .CPOOL + +INT_TO_MASK_TABLE: + .WORD %00001111_11111111_11111111_11111111 + .WORD %11110000_11111111_11111111_11111111 + .WORD %11111111_00001111_11111111_11111111 + .WORD %11111111_11110000_11111111_11111111 + .WORD %11111111_11111111_00001111_11111111 + .WORD %11111111_11111111_11110000_11111111 + .WORD %11111111_11111111_11111111_00001111 + .WORD %11111111_11111111_11111111_11110000 + +; draw a line between two points +; parameters: x0, y0, x1, y1, color + .EQU DL_X0 0 + .EQU DL_Y0 4 + .EQU DL_X1 8 + .EQU DL_Y1 12 + .EQU DL_DX 16 + .EQU DL_DY 20 + .EQU DL_ERR 24 + .EQU DL_E2 28 + .EQU DL_SX 32 + .EQU DL_SY 36 + .EQU DL_COL 40 + .EQU STACKFRAME_SIZE 44 + +DRAWLINE_M: + LOADC 1 +DRAWLINE: + FPADJ -STACKFRAME_SIZE + + STORE DL_COL ; store args + STORE DL_Y1 + STORE DL_X1 + STORE DL_Y0 + STORE DL_X0 + + LOAD DL_X1 ; dx = abs(x1-x0) + LOAD DL_X0 + SUB + LOADCP ABS + CALL + STORE DL_DX + + LOAD DL_Y1 ; dy = -abs(y1-y0) + LOAD DL_Y0 + SUB + LOADCP ABS + CALL + DEC 1 + NOT + STORE DL_DY + + LOAD DL_X0 ; sx = (x0 dy + LOAD DL_DY + CMP GT + CBRANCH.Z DL_SKIP1 + + LOAD DL_ERR ; err += dy + LOAD DL_DY + ADD + STORE DL_ERR + + LOAD DL_X0 ; x0 += sx + LOAD DL_SX + ADD + STORE DL_X0 + +DL_SKIP1: + LOAD DL_E2 ; if e2 < dx + LOAD DL_DX + CMP LT + CBRANCH.Z DL_SKIP2 + + LOAD DL_ERR ; err += dx + LOAD DL_DX + ADD + STORE DL_ERR + + LOAD DL_Y0 ; y0 += sy + LOAD DL_SY + ADD + STORE DL_Y0 + +DL_SKIP2: + BRANCH DL_LOOP +DL_END: + FPADJ STACKFRAME_SIZE + RET + +; initialize the palette registers +INITPALETTE: + LOADCP DEFAULT_PALETTE ; load pointer to color table + LOADC 0 ; load counter +INITPAL_0: + DUP + LOADC FB_PS ; store counter to palette select register + SWAP ; swap addr and value for STOREI + STOREI + DROP + + SWAP ; pointer on top of stack + DUP + LOADI ; load color value + LOADC FB_PD + SWAP ; swap addr and value for STOREI + STOREI ; store to palette data register + DROP + INC 4 ; increment pointer + + SWAP ; counter on top of stack + DUP + LOADC 15 + CMPU EQ + CBRANCH INITPAL_X ; exit if counter is 15 + + INC 1 ; increment counter + BRANCH INITPAL_0 + +INITPAL_X: + DROP ; remove counter and pointer + DROP + RET + +; set a palette register +; parameters [ palette slot nr, color value ] +SETPALETTE: + SWAP ; slot nr to top + LOADC FB_PS ; load address of palette select register + SWAP ; swap addr and slot nr for STOREI + STOREI + DROP ; remove addr from STOREI + ; left on stack now: color value + LOADC FB_PD ; load address of palette data register + SWAP ; swap addr and color value for STOREI + STOREI + DROP ; remove addr + + RET + +DEFAULT_PALETTE: + .WORD 0, $FFF, $F00, $0F0, $00F, $0FF, $F0F, $FF0 + .WORD $777, $777, $700, $070, $007, $077, $707, $770 + +; set whole video memory to zero +CLEARGRAPHICS: + LOADC 0 +CL_LOOP: + LOADC FB_WA + OVER ; duplicate value + STOREI + DROP + + LOADC FB_IO + LOADC 0 + STOREI + DROP + + INC 1 + + LOADCP 32768 + CMP.S0 NE + CBRANCH CL_LOOP + + DROP + + RET + +INITGRAPHICS: + LOADCP CLEARGRAPHICS + CALL + LOADCP INITPALETTE + CALL + RET + +; wait for vertical blank +; we first wait for the VBLANK bit +; to become zero to make sure we +; catch the beginning of the vertical blank +WAITVSYNC: + ; wait for VBLANK to become zero + LOADC FB_CTL + LOADI ; read control register + LOADC 1 ; check bit 0 (VBLANK) + AND + CBRANCH.NZ WAITVSYNC ; if set, loop +VSYNC_WAIT1: + ; wait for VBLANK to become one + LOADC FB_CTL + LOADI ; read control register + LOADC 1 ; check bit 0 (VBLANK) + AND + CBRANCH.Z VSYNC_WAIT1 ; if not set, loop + RET + +; args: number of bytes, pointer to buf, +HEXDUMP: + DUP + LOADI + LOADCP PRINTHEXW + CALL + LOADC ' ' + LOADCP CONOUT + CALL + INC 4 + + DUP + LOADI + LOADCP PRINTHEXW + CALL + LOADC ' ' + LOADCP CONOUT + CALL + INC 4 + + DUP + LOADI + LOADCP PRINTHEXW + CALL + LOADC ' ' + LOADCP CONOUT + CALL + INC 4 + + DUP + LOADI + LOADCP PRINTHEXW + CALL + LOADC ' ' + LOADCP CONOUT + CALL + INC 4 + + LOADCP NEWLINE + CALL + + SWAP ; swap pointer and counter + LOADC 16 + SUB + DUP + CBRANCH.Z HEXDUMP_END ; end if counter is zero + SWAP ; swap back counter and pointer + BRANCH HEXDUMP + +HEXDUMP_END: + DROP + DROP + RET + +; inquire cursor position +; args: pointer to columns variable, pointer to rows variable +GETCURSORPOS: + LOADCP TERM_CPR_STR + LOADCP PRINTLINE + CALL + + LOADCP CONIN ; skip ESC + CALL + DROP + LOADCP CONIN ; and '[' + CALL + DROP + + LOADC ';' + LOADCP _TERMRCVINT + CALL + STOREI + DROP + + LOADC 'R' + LOADCP _TERMRCVINT + CALL + STOREI + DROP + + RET + +; receive digits and compose an integer value +; up to a termination character or an ';' +; args: termination character +; returns: -1 on error (invalid digit) + +_TERMRCVINT: + FPADJ -4 + STORE 0 + + LOADC 0 ; start with 0 value +RCVINT_L: + LOADCP CONIN + CALL + + DUP ; duplicate received char + LOAD 0 ; compare with terminator + CMP EQ ; if equal, + CBRANCH RCVINT_XT ; exit + + LOADC '0' ; subtract ascii value to get + SUB ; numerical value + + DUP + LOADC 0 ; check if less than zero + CMP LT + CBRANCH RCVINT_ERR ; if yes, error + + DUP + LOADC 9 + CMP GT ; check if > 9 + CBRANCH RCVINT_ERR ; if yes, error + + SWAP + LOADCP _MUL10 ; old value * 10 (shift digits to the left) + CALL + + ADD ; add to value + BRANCH RCVINT_L ; next digit +RCVINT_ERR: + DROP + DROP + LOADC -1 + BRANCH RCVINT_XT2 +RCVINT_XT: + DROP +RCVINT_XT2: + FPADJ 4 + RET + +TERM_CPR_STR: .BYTE 27, "[6n", 0 ; ANSI Cursor Position Report + + .CPOOL + +GETTICKS: + LOADC IRQC_REG + LOADI + LOADC -256 + AND + BROT + BROT + BROT + RET + + .EQU CRLD_BLOCK 0 + .EQU CRLD_BYTES 4 + .EQU CRLD_ADDR 8 + .EQU CRLD_FS 12 + +; load a program image from sd card +; args: device id, block no, size in bytes +CORELOAD: + ; We need to set the FP and RP registers, + ; because we might overwrite that + ; memory area where the calling program + ; has its user and return stack + + LOADCP FP_START + STOREREG FP + LOADCP RP_START + STOREREG RP + + FPADJ -CRLD_FS + STORE CRLD_BYTES + STORE CRLD_BLOCK + DROP ; ignore device ID, + ; we support only one sd card + + ; divide bytes by 512 and add one + ; to get block count + LOAD CRLD_BYTES + LOADC 9 + LOADCP _SHRM + CALL + INC 1 + ; keep block count on stack + + ; start at address 24576 + LOADCP PROG_START + STORE CRLD_ADDR + +CRLD_LP: + ; read a block + LOAD CRLD_BLOCK + LOADCP CARDREADBLK + CALL + DROP ; ignore error for now + + LOAD CRLD_ADDR + LOADCP CARD_BUF + LOADC 128 + LOADCP _COPYWORDS + CALL + + ; advance dest pointer + LOAD CRLD_ADDR + LOADC 512 + ADD + STORE CRLD_ADDR + + ; increment block number + LOAD CRLD_BLOCK + INC 1 + STORE CRLD_BLOCK + + ; decrement block count on stack + DEC 1 + DUP + CBRANCH.NZ CRLD_LP ; if block count not zero, loop + DROP ; remove block count +CRLD_CLEAN: + ; clean up partial block + LOADC 512 + LOAD CRLD_BYTES + INC 3 ; round up to next word + LOADC -4 + AND + LOADC 511 ; get remainder by 512 + AND + SUB ; subtract to get number of remaining bytes + ; in last block + + LOAD CRLD_ADDR ; this is now the addr of the last + ; byte in the last block + 1 + OVER ; duplicate number of remaining bytes + SUB ; and subtract from addr + + SWAP ; swap addr and number of remaining bytes + LOADCP _CLEARMEM + CALL + + ; clear estack + + ; release our stack frame + FPADJ CRLD_FS + + ; jump to program start address + LOADCP PROG_START + JUMP + + ; no RET + + .CPOOL + +READDIRBLK: +; parameters: [ blkno, ptr to DirBlock, ptr to error return value, device id ] +; same routine as READBLOCK, is referenced by two names to convert buffer types + +; parameters: [ blkno, ptr to PartitionTableBlock, ptr to error return value, device id ] +READPARTBLK: +; same routine as READBLOCK, is referenced by two names to convert buffer types + +READBLOCK: +; parameters: [ blkno, ptr to IOBlock, ptr to error return value, device id ] + DROP ; ignore device id + + LOADC 0 + STOREI ; set return value to zero + DROP + SWAP ; swap blkno and ptr + LOADCP CARDREADBLK ; read that block number + CALL + DROP ; ignore error for now + ; TODO: store it via error ptr + ; ptr to PartitionTableBlock is now on ToS + LOADCP CARD_BUF + LOADC 128 + LOADCP _COPYWORDS ; copy block to destination buffer + CALL + + RET + +WRITEPARTBLK: +WRITEDIRBLK: +; parameters: [ blkno, ptr to IOBlock, ptr to error return value, device id ] +WRITEBLOCK: + DROP ; ignore device id + + LOADC 0 + STOREI ; set return value to zero + DROP + + LOADCP CARD_BUF + SWAP + LOADC 128 + LOADCP _COPYWORDS ; copy block to card_buf + CALL + + LOADCP CARDWRITEBLK ; write that block number + CALL + DROP ; ignore error for now + ; TODO: store it via error ptr + ; ptr to PartitionTableBlock is now on ToS + RET + +%include "sdcardlib.s" + + .CPOOL + +SHELLWORKFILE: .WORD 0,68 + .BLOCK 17 +SHELLCMD: .WORD 0,40 + .BLOCK 8 +SHELLARG: .WORD 0 +PARGCOUNT: .WORD 0 +PARGS: .WORD 0,80 + .BLOCK 20 + .WORD 0,80 + .BLOCK 20 + .WORD 0,80 + .BLOCK 20 + .WORD 0,80 + .BLOCK 20 + .WORD 0,80 + .BLOCK 20 + .WORD 0,80 + .BLOCK 20 + .WORD 0,80 + .BLOCK 20 + .WORD 0,80 + .BLOCK 20 + +DEFAULTVOLUME: .WORD 0,32 + .BLOCK 8 + +SYSCLOCK: + .BLOCK 6 +SYSBOOTTICKS: + .WORD 0 +SYSLASTTICKS: + .WORD 0 + +; copy words to screen memory +; args: pointer to 32000 words of pixel data +PUTSCREEN: + LOADC FB_WA + LOADC 0 ; initialize write address register + STOREI + DROP + + LOADCP 32000 ; word count +PUTSCREEN_L0: + SWAP ; [ count, addr ] + DUP + LOADI ; load pixel word + LOADC FB_IO + SWAP ; swap addr and value for STOREI + STOREI ; store to vmem io register + DROP + + INC 4 ; next word + + SWAP ; swap addr and count + DEC 1 ; decrement count + + DUP + CBRANCH.NZ PUTSCREEN_L0 ; loop if count is not zero + + DROP ; remove counter and addr + DROP + + RET + + +%export _MUL +%export _MULU +%export _DIV +%export _DIVU +%export _MOD +%export _DIVMODU +%export _SHRM +%export _SHLM +%export _COPYWORDS +%export _CMPWORDS +%export _CLEARMEM diff --git a/lib/coreloader.s b/lib/coreloader.s new file mode 100644 index 0000000..542b667 --- /dev/null +++ b/lib/coreloader.s @@ -0,0 +1,279 @@ +; Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details + .ORG 4096 + +CORELOADER: + ; initialize program stack and + ; return stack pointers + LOADCP 24060 + STOREREG FP + LOADCP 24064 + STOREREG RP + + LOADCP SYSBOOTTICKS + LOADCP GETTICKS + CALL + STOREI + DROP + + LOADCP INITSDCARD + CALL + + ;LOADCP FIND_SYSPART ; no need to call, it never + ;CALL ; returns, so just fall through + + .EQU PART_START 0 + .EQU EXTENT_SIZE 4 + .EQU DIR_SIZE 8 + .EQU SLOT_NO 12 + .EQU SIZE_BYTES 16 + .EQU PRG_START_BLK 20 + .EQU FIND_FS 24 + + .EQU PARTENTRY_SIZE 64 + .EQU DIRENTRY_SIZE 64 +FIND_SYSPART: + FPADJ -FIND_FS + ; load block 0 + LOADC 0 + LOADCP CARDREADBLK + CALL + + DUP ; non-zero return code means error + CBRANCH.Z FIND_1 + + LOADCP PRINTHEXW + CALL + LOADCP NEWLINE + CALL + LOADC 0 + JUMP + +FIND_1: + DROP ; remove return code + + ;LOADC 512 + ;LOADCP CARD_BUF + ;LOADCP HEXDUMP + ;CALL + + ; address of the first partition entry + LOADCP CARD_BUF +FIND_L: + DUP ; dup addr for comparison + LOADCP SYSPART_NAME + LOADC SYSNAME_WORDS + LOADCP _CMPWORDS + CALL + CBRANCH.NZ FIND_FOUND + ; go to next entry + LOADC PARTENTRY_SIZE + ADD + + ; check if address is still + ; within the data block + DUP + LOADCP CARD_BUF,512 + CMP LT + CBRANCH FIND_L + + ; remove address + DROP + + ; not found, complain and + ; go back to ROM monitor + LOADCP SYSPART_ERR + LOADCP PRINTLINE + CALL + + LOADC 0 + JUMP + +FIND_FOUND: + ; address of the part entry is on stack + + ; check if partition is enabled + DUP ; duplicate address + LOADC 40 ; add PartFlags field offset + ADD + LOADI + LOADC 1 + AND ; check bit 0 (PartEnabled) + CBRANCH.Z FIND_L ; if not set, continue loop + + + ; address of part entry is still on stack + DUP + LOADC 44 ; add startBlock field offset + ADD + LOADI ; get start block number + STORE PART_START + + ; address of part entry is still on stack + DUP + LOADC 52 ; move to extentSize field + ADD + LOADI ; get value + STORE EXTENT_SIZE + + ; address of part entry is still on stack + LOADC 56 ; move to dirSize field + ADD + LOADI ; get value + STORE DIR_SIZE + + LOADC 0 + STORE SLOT_NO ; start with dirslot 0 + + LOAD PART_START ; start with first block of the partition +FIND_FILE: + DUP ; duplicate block number + LOADCP CARDREADBLK ; read that block + CALL + DROP ; ignore error + + ; scan directory entries for shell file name + LOADCP CARD_BUF +FIND_FILE_L: + DUP + LOADCP SHELL_NAME + LOADC SHELLNAME_WORDS + LOADCP _CMPWORDS ; compare names + CALL + CBRANCH.NZ FIND_F_FOUND ; exit loop if names match + + ; check if current dirslot no + ; is below maximum number of slots + LOAD SLOT_NO + LOAD DIR_SIZE + CMP GE + CBRANCH FIND_F_NOTFOUND ; max slots reached, exit + + ; add 1 to SLOT_NO + LOAD SLOT_NO + INC 1 + STORE SLOT_NO + + ; address is still on stack + LOADC DIRENTRY_SIZE + ADD ; go to next dir entry + + ; check if address is still + ; below end of data block + DUP + LOADCP CARD_BUF,512 + CMP LT + CBRANCH FIND_FILE_L ; if it is below, loop + + DROP ; remove dir entry addr + + ; block no is still on stack + INC 1 + BRANCH FIND_FILE ; read next block + +FIND_F_NOTFOUND: + LOADCP SHELL_ERR + LOADCP PRINTLINE + CALL + + ; remove entry addr and block number + DROP + DROP + LOADC 0 + JUMP + +FIND_F_FOUND: + ; found the file name, now check if it has the right flags + + ; address of dir entry is still on stack + DUP + LOADC 40 ; add flags field offset + ADD + LOADI ; load flags + LOADC 16 ; test for SlotFirst flag + AND + CBRANCH.Z FIND_FILE_L ; if not set, continue loop + + ;LOADCP FOUND_MSG + ;LOADCP PRINTLINE + ;CALL + + ; we got the right file, now calculate start block + ; and get file size from dir entry + + ; address of dir entry is still on stack + ; phys start block = part start + slot_no * (extent_size/512) + LOAD EXTENT_SIZE + LOADC 9 + LOADCP _SHRM + CALL + LOAD SLOT_NO + LOADCP _MUL + CALL + LOAD PART_START + ADD + + ;DUP + ;LOADCP PRINTHEXW + ;CALL + ;LOADC ' ' + ;LOADCP CONOUT + ;CALL + + STORE PRG_START_BLK + + ; address of dir entry is still on stack + LOADC 44 + ADD ; add sizeBytes field offset + LOADI ; get size in bytes + + ;DUP + ;LOADCP PRINTHEXW + ;CALL + ;LOADCP NEWLINE + ;CALL + + STORE SIZE_BYTES + + ; remove block number + DROP + + ; set argument count to 0 + ; in case this gets called + ; by a terminating program + LOADCP PARGCOUNT + LOADC 0 + STOREI + DROP + + LOADC 0 ; device id is always 0 + LOAD PRG_START_BLK + LOAD SIZE_BYTES + ; release our stack frame + FPADJ FIND_FS + + ; load program + LOADCP CORELOAD + CALL + + LOADC 0 + JUMP + + .CPOOL + + .EQU SYSNAME_WORDS 4 +SYSPART_NAME: + .WORD 6, 32 + .BYTE "SYSTEM" +SYSPART_ERR: + .BYTE "No ""SYSTEM"" partition.",13,10,10,0 + .EQU SHELLNAME_WORDS 5 +SHELL_NAME: + .WORD 10,32 + .BYTE "shell.prog" +SHELL_ERR: + .BYTE "No shell on ""SYSTEM"" partition.",13,10,10,0 + +FOUND_MSG: + .BYTE " shell.prog ",0 + +%include corelib.s diff --git a/lib/float32.s b/lib/float32.s new file mode 100644 index 0000000..4b0ad9c --- /dev/null +++ b/lib/float32.s @@ -0,0 +1,1053 @@ +; Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details + +; FLOAT32 format: +;| 31 | 30-8 | 7-0 | +;|sign| fraction | exp | + +; exp has a bias of 128 +; sign = 1: negative number + + .EQU FLOAT32_EXPMASK %00000000000000000000000011111111 + .EQU FLOAT32_FRCMASK %01111111111111111111111100000000 + .EQU FLOAT32_SGNMASK %10000000000000000000000000000000 + .EQU FLOAT32_FRCMSBM %01000000000000000000000000000000 + .EQU FLOAT32_OVRFLOW %10000000000000000000000000000000 + .EQU FLOAT32_RNDMASK %00000000000000000000000010000000 + .EQU FLOAT32_RNDINCR %00000000000000000000000100000000 + .EQU FLOAT32_FRCLSB %00000000000000000000000100000000 + + .EQU FLOAT32_MAX_EXP 255 + .EQU FLOAT32_BIAS 127 + .EQU FLOAT32_FRCBITS 23 + .EQU FLOAT32_EXP_BITS 8 + +; unpack a float32 value into +; three fields: exponent, fraction, sign +; ptr is a pointer to an array with the three fields +; the sign flag is 0 or 1. + +; parameters: [ floatval, ptr ] +_UNPACKFLOAT32: + OVER ; [ float, ptr, float ] + LOADC FLOAT32_EXPMASK ; [ float, ptr, float, mask ] + AND ; [ float, ptr, exp ] + STOREI 4 ; [ float, ptr + 4 ] + OVER ; [ float, ptr + 4, float ] + LOADCP FLOAT32_FRCMASK ; [ float, ptr + 4 , float, mask ] + AND ; [ float, ptr + 4 , frac ] + STOREI 4 ; [ float, ptr + 8 ] + SWAP ; [ ptr + 8, float ] + LOADCP FLOAT32_SGNMASK ; [ ptr + 8, float, mask ] + AND ; [ ptr + 8, signbit ] + LOADC 0 ; [ ptr + 8, signbit, 0 ] + CMPU NE ; [ ptr + 8, sign ] + STOREI ; [ ptr + 8 ] + DROP ; [] + RET + +; pack exponent, fraction, sign into a single 32-bit value +; ptr is a pointer to an array with the three fields +; parameters: [ ptr ] +; returns: float value +_PACKFLOAT32: + LOADI.S1.X2Y ; [ ptr, exp ] + OVER ; [ ptr, exp, ptr ] + INC 4 ; [ ptr, exp, ptr + 4 ] + LOADI ; [ ptr, exp, frac ] + LOADCP FLOAT32_FRCMASK ; [ ptr, exp, frac, mask ] + AND ; [ ptr, exp, frac ] + OR ; [ ptr, exp|frac ] + OVER ; [ ptr, exp|frac, ptr ] + INC 8 ; [ ptr, exp|frac, ptr + 8] + LOADI ; [ ptr, exp|frac, signflag ] + CBRANCH.Z PACKFL_1 ; [ ptr, exp | frac ] + LOADCP FLOAT32_SGNMASK ; [ ptr, exp|frac, signmask ] + ADD ; [ ptr, floatval ] +PACKFL_1: + SWAP ; [ floatval, ptr ] + DROP ; [ floatval ] + RET + +; adds to floating point values a and b +; parameters: [ a, b ] +; returns: sum of a and b + .EQU FL_E_A 0 + .EQU FL_F_A 4 + .EQU FL_S_A 8 + .EQU FL_E_B 12 + .EQU FL_F_B 16 + .EQU FL_S_B 20 + .EQU FL_E_R 24 + .EQU FL_F_R 28 + .EQU FL_S_R 32 + .EQU ADDFL_SUB 36 + .EQU ADDFL_FS 40 + +_ADDFLOAT32: + FPADJ -ADDFL_FS + ; unpack b into e_b and f_b + LOADREG FP + LOADC FL_E_B + ADD ; addr of FL_E_B + LOADCP _UNPACKFLOAT32 + CALL + ; unpack a into e_a and f_a + LOADREG FP ; addr of FL_E_A + LOADCP _UNPACKFLOAT32 + CALL + + + ; if abs(a) < abs(b), swap a and b (this includes e_a < e_b) + LOAD FL_E_A + LOAD FL_E_B + CMPU GT + CBRANCH ADDFL_1 ; don't swap if e_a > e_b + ; e_a <= e_b + ; check if e_a < e_b + LOAD FL_E_A + LOAD FL_E_B + CMPU LT + CBRANCH ADDFL_1_1 ; swap if e_a < e_b + ; e_a = e_b + ; check fractions + LOAD FL_F_A + LOAD FL_F_B + CMPU GE + CBRANCH ADDFL_1 ; dont't swap if f_a >= f_b + +ADDFL_1_1: + ;LOADC '"' + ;LOADCP CONOUT + ;CALL + + LOAD FL_E_A + LOAD FL_E_B + STORE FL_E_A + STORE FL_E_B + LOAD FL_F_A + LOAD FL_F_B + STORE FL_F_A + STORE FL_F_B + LOAD FL_S_A + LOAD FL_S_B + STORE FL_S_A + STORE FL_S_B +ADDFL_1: + ; e_r := e_a, result exp is exp from a + LOAD FL_E_A + STORE FL_E_R + + LOAD FL_S_A ; take result sign from a (which might be swapped with b here) + STORE FL_S_R + + LOAD FL_S_A ; check if the signs of a and b differ + LOAD FL_S_B + XOR ; if the xor of both sign flags is 1, signs are not the same + STORE ADDFL_SUB ; then we do a subtraction later + + ; ? if (e_a - e_b) > precision +1: + ; ? set f_r to f_a + + ; shift right f_b by (e_a - e_b) bits + LOAD FL_E_A + LOAD FL_E_B + SUB + + ;LOADCP NEWLINE + ;CALL + ;LOADC 'e' + ;LOADCP CONOUT + ;CALL + ;DUP + ;LOADCP PRINTDEC + ;CALL + ;LOADCP NEWLINE + ;CALL + + LOAD FL_F_B ; on stack now: [ counter, f_b ] +ADDFL_L1: + OVER ; check counter for zero + CBRANCH.Z ADDFL_2 ; if yes, loop is done + SHR ; shift right + SWAP ; swap counter and value + DEC 1 ; decrement counter + SWAP ; swap back + BRANCH ADDFL_L1 ; next +ADDFL_2: + STORE FL_F_B ; store result + DROP ; remove counter + + ;LOADC 'a' + ;LOADCP CONOUT + ;CALL + ;LOAD FL_F_A + ;LOADCP PRINTHEXW + ;CALL + ;LOADCP NEWLINE + ;CALL + ;LOADC 'b' + ;LOADCP CONOUT + ;CALL + ;LOAD FL_F_B + ;LOADCP PRINTHEXW + ;CALL + ;LOADCP NEWLINE + ;CALL + + ; set f_r to f_a + f_b + ; (or f_r = f_a - f_b if we have a negative sign somewhere) + LOAD FL_F_A + LOAD FL_F_B + LOAD ADDFL_SUB ; do we need a subtract? + CBRANCH ADDFL_2_1 ; yes, skip add instruction + ADD ; no, do add and skip sub instruction + BRANCH ADDFL_2_2 +ADDFL_2_1: + ;LOADC '-' + ;LOADCP CONOUT + ;CALL + ;LOADCP NEWLINE + ;CALL + + SUB +ADDFL_2_2: + ;DUP + ;LOADCP PRINTHEXW + ;CALL + ;LOADCP NEWLINE + ;CALL + + ; normalize: + ; if overflow bit of f_r is set, scale right + DUP + LOADCP FLOAT32_OVRFLOW ; isolate overflow bit + AND + + CBRANCH.Z ADDFL_3 + + ;LOADC 'V' + ;LOADCP CONOUT + ;CALL + + ; scale right: shift right f_r by one, increment e_r by one + SHR + LOAD FL_E_R + INC 1 + STORE FL_E_R +ADDFL_3: + ; check if result is zero + DUP + CBRANCH.NZ ADDFL_3_1 + ; set exponent to something useful + LOADC 0 + STORE FL_E_R + ; clear sign, we don't want -0 + LOADC 0 + STORE FL_S_R + + BRANCH ADDFL_4 + +ADDFL_3_1: + ; if bit 30 of f_r is zero, scale left + DUP + LOADCP FLOAT32_FRCMSBM ; isolate msb of fraction + AND + CBRANCH.NZ ADDFL_4 + + ;LOADC '<' + ;LOADCP CONOUT + ;CALL + ;LOADCP NEWLINE + ;CALL + + ; scale left and repeat previous step + SHL ; shift fraction + LOAD FL_E_R ; decrement exponent + DEC 1 + STORE FL_E_R + BRANCH ADDFL_3 ; repeat +ADDFL_4: + ; round: + ; simple round algorithm: if the bit below + ; the least significat bit is 1, round up + ; and check the overflow bit again + + DUP + LOADC FLOAT32_RNDMASK ; test rounding bit + AND + CBRANCH.Z ADDFL_5 ; if not set, skip rounding + + ;LOADC '~' + ;LOADCP CONOUT + ;CALL + ;LOADCP NEWLINE + ;CALL + + LOADC FLOAT32_RNDINCR + ADD + + LOADCP FLOAT32_FRCMASK ; remove rounded off bits + AND + + BRANCH ADDFL_3_1 ; check for overflow again +ADDFL_5: + + STORE FL_F_R + + ;LOADCP NEWLINE + ;CALL + ;LOADC 'E' + ;LOADCP CONOUT + ;CALL + + ;LOAD FL_E_R + ;LOADCP PRINTHEXW + ;CALL + ;LOADCP NEWLINE + ;CALL + + ; check exponent range overflow + LOADCP FLOAT32_EXP_CHECK + CALL +ADDFL_6: + ; pack e_r,f_r,s_r into r + LOADREG FP + LOADC FL_E_R + ADD + LOADCP _PACKFLOAT32 + CALL + + FPADJ ADDFL_FS + RET + +; check exponent value of local var FL_E_R +; for overflow and issue runtime error on failure. +; uses stack frame of caller. +FLOAT32_EXP_CHECK: + ; check exponent range overflow + LOAD FL_E_R + LOADC FLOAT32_MAX_EXP + CMPU LE + CBRANCH FLOAT32_EXP_XT + + LOADCP FLOAT32_ERR_OVR + LOADCP _RUNTIME_ERR + JUMP +FLOAT32_EXP_XT: + RET + +; subtract floating point value b from a +; parameters: [ a, b ] +; returns: a - b +_SUBFLOAT32: + ; just flip sign bit of b and continue with _ADDFLOAT32 + LOADCP $80000000 + XOR + BRANCH _ADDFLOAT32 + +; multiply two floating point values a and b +; parameters: [ a, b ] +; returns: a * b + .EQU MULFL_FS 36 +_MULFLOAT32: + FPADJ -MULFL_FS ; same stack frame layout as _ADDFLOAT32 + + DUP + CBRANCH.NZ _MULFLOAT32_1 ; check if b is zero + ; if yes, just return zero + NIP ; remove a, take b (which is zero) as return value + BRANCH _MULFLOAT32_X +_MULFLOAT32_1: + ; unpack b into e_b and f_b + LOADREG FP + LOADC FL_E_B + ADD ; addr of FL_E_B + LOADCP _UNPACKFLOAT32 + CALL + + DUP + CBRANCH.NZ _MULFLOAT32_2 ; check if a is zero + ; if yes, return zero + ; take a (which is zero) as return value + BRANCH _MULFLOAT32_X +_MULFLOAT32_2: + ; unpack a into e_a and f_a + LOADREG FP ; addr of FL_E_A + LOADCP _UNPACKFLOAT32 + CALL + + ; s_r = s_a xor s_b + LOAD FL_S_A + LOAD FL_S_B + XOR + STORE FL_S_R + + ; e_r = e_a + e_b - bias + LOAD FL_E_A + LOAD FL_E_B + ADD + LOADC FLOAT32_BIAS + SUB + STORE FL_E_R + + ; check exponent range overflow + LOADCP FLOAT32_EXP_CHECK + CALL + ; f_r = fractmult(f_a, f_b) + LOADCP _FRACTMULT + CALL + + LOADCP NORMROUND_FL ; normalize and round + CALL + + ; pack result + LOADREG FP + LOADC FL_E_R + ADD + LOADCP _PACKFLOAT32 + CALL +_MULFLOAT32_X: + ; 32 bit float result is now on stack + FPADJ MULFL_FS + RET + +; multiply fractions. +; uses stack frame/local variables from caller. +; FL_F_B is destroyed. +; result is written to FL_R +_FRACTMULT: + LOADC FLOAT32_FRCBITS ; this is the counter which we keep on stack + + LOADC 0 ; start with result zero + STORE FL_F_R + + ; for each digit of the fraction of b, from right to left, + ; the fraction of a is added to the result, if that digit is 1. + ; on each iteration, the result is shifted right. +_FRACTMULT_1: + LOAD FL_F_R + SHR + STORE FL_F_R ; shift result frac for next iteration + + LOAD FL_F_B + LOADC FLOAT32_FRCLSB + AND ; isolate lowest bit + + CBRANCH.Z _FRACTMULT_2 ; if not set, don't add in this iteration + + LOAD FL_F_R ; otherwise, add fraction of a to result + LOAD FL_F_A + ADD + STORE FL_F_R + +_FRACTMULT_2: + LOAD FL_F_B + SHR + STORE FL_F_B ; shift fraction b for next digit + + DEC 1 ; decrease counter + DUP + CBRANCH _FRACTMULT_1 ; if not zero, next loop iteration + + DROP ; drop counter + RET + +; divide floating point value a by b +; parameters: [ a, b ] +; returns: a / b + .EQU DIVFL_FS 36 +_DIVFLOAT32: + FPADJ -DIVFL_FS ; same stack frame layout as _ADDFLOAT32 + DUP + CBRANCH.NZ _DIVFLOAT32_0 ; check b for zero + LOADCP FLOAT32_ERR_DIVZ ; if it is, we have a division by zero + LOADCP _RUNTIME_ERR ; and we issue a runtime error + JUMP +_DIVFLOAT32_0: + OVER ; check a for zero + CBRANCH.NZ _DIVFLOAT32_0_1 + ; if it is we just return zero + DROP ; remove args + DROP + LOADC 0 + BRANCH _DIVFLOAT32_XT + +_DIVFLOAT32_0_1: + ; unpack b into e_b and f_b + LOADREG FP + LOADC FL_E_B + ADD ; addr of FL_E_B + LOADCP _UNPACKFLOAT32 + CALL + ; unpack a into e_a and f_a + LOADREG FP ; addr of FL_E_A + LOADCP _UNPACKFLOAT32 + CALL + + ; s_r = s_a xor s_b + LOAD FL_S_A + LOAD FL_S_B + XOR + STORE FL_S_R + + ; e_r = e_a - e_b + bias + LOAD FL_E_A + LOAD FL_E_B + SUB + LOADC FLOAT32_BIAS + ADD + STORE FL_E_R + + ; check exponent range overflow + LOADCP FLOAT32_EXP_CHECK + CALL + ; f_r = fractdiv(f_a, f_b) + LOADCP _FRACTDIV + CALL + + LOADCP NORMROUND_FL ; normalize and round + CALL + + ; pack result + LOADREG FP + LOADC FL_E_R + ADD + LOADCP _PACKFLOAT32 + CALL +_DIVFLOAT32_XT: + ; 32 bit float result is now on stack + FPADJ DIVFL_FS + RET + +; divide fraction of a by b. +; uses stackframe of caller. +; FL_F_A is destroyed. +; places result into FL_F_R. +_FRACTDIV: + LOADC 0 + STORE FL_F_R + + LOADC FLOAT32_FRCBITS ; load counter +_FRACTDIV_1: + LOAD FL_F_R ; load result for later + LOAD FL_F_B + LOAD FL_F_A + CMPU GT + CBRANCH _FRACTDIV_2 ; if b > a, skip next section + INC 1 ; a fits into b, so add 1 to result + LOAD FL_F_A ; subtract divisor from dividend + LOAD FL_F_B + SUB + STORE FL_F_A + +_FRACTDIV_2: + SHL ; shift result left for next digit + STORE FL_F_R ; and store it again + LOAD FL_F_A ; shift the dividend left for next digit + SHL + STORE FL_F_A + + DEC 1 ; decrement counter + DUP + CBRANCH.NZ _FRACTDIV_1 ; loop if it is not zero + + DROP ; remove counter + + LOAD FL_F_R ; undo the last shift of the result + SHR + BROT ; and shift left again to make room for the exponent + STORE FL_F_R + RET + + +; normalize and round f_r. +; uses stack frame of caller. +NORMROUND_FL: + LOAD FL_F_R +NORMFL_0: + ; if overflow bit of f_r is set, scale right + DUP + LOADCP FLOAT32_OVRFLOW ; isolate overflow bit + AND + CBRANCH.Z NORMFL_1 ; if bit is zero, skip the scaling + + ; scale right: shift right f_r by one, increment e_r by one + SHR + LOAD FL_E_R + INC 1 + STORE FL_E_R + +NORMFL_1: + ; check if result is zero + DUP + CBRANCH.NZ NORMFL_1_1 + ; set exponent to something useful + LOADC 0 + STORE FL_E_R + ; clear sign flag, we don't want -0 + LOADC 0 + STORE FL_S_R + + BRANCH NORMFL_2 + + ; normalize: + ; if bit 30 of f_r is zero, scale left +NORMFL_1_1: + DUP + LOADCP FLOAT32_FRCMSBM ; isolate msb of fraction + AND + CBRANCH.NZ NORMFL_2 ; skip if bit is set + ; scale left and repeat previous step + SHL ; shift fraction + LOAD FL_E_R ; decrement exponent + DEC 1 + STORE FL_E_R + BRANCH NORMFL_1_1 ; repeat + +NORMFL_2: + ; round: + ; simple round algorithm: if the bit below + ; the least significat bit is 1, round up + ; and check the overflow bit again + DUP + LOADC FLOAT32_RNDMASK ; test rounding bit + AND + CBRANCH.Z NORMFL_3 ; if not set, skip rounding + + LOADC FLOAT32_RNDINCR + ADD + + LOADCP FLOAT32_FRCMASK ; remove rounded off bits + AND + + BRANCH NORMFL_0 ; check for overflow again +NORMFL_3: + STORE FL_F_R + RET + +; return the fractional part of a floating point number +; parameters: float32 value +; returns: float32 value + .EQU FRACTFL_EXP 12 + .EQU FRACTFL_FS 20 +_FRACTFLOAT32: + FPADJ -FRACTFL_FS + DUP ; check for zero + CBRANCH.Z FRACTFL_XT ; if yes, just return zero + LOADREG FP + LOADCP _UNPACKFLOAT32 + CALL + + LOAD FL_E_A ; remove bias from exponent + LOADC FLOAT32_BIAS + SUB + DUP + STORE FRACTFL_EXP + + LOADC 0 ; if the exponent is negative, + CMP LT ; there are no digits before the point + CBRANCH FRACTFL_PK ; and we just return the same value + + LOAD FRACTFL_EXP ; the exponent indicates how far + ; we need to shift the fraction to the left + INC 1 ; at exp 0 we need to shift by 1 + + LOADC FLOAT32_BIAS - 1 + STORE FL_E_A ; the new exponent is -1 because we + ; shifted by (old exp + 1) bits + + LOAD FL_F_A ; load fraction, shift count is already on stack +FRACTFL_L: + SHL ; shift fraction + SWAP ; swap fraction and shift count + DEC 1 ; decrement count + SWAP ; swap back shift count and fraction + OVER ; check count for zero + CBRANCH FRACTFL_L ; if not, loop + + NIP ; remove count + LOADCP FLOAT32_FRCMASK + AND ; remove superfluous bits + + DUP ; check if fraction is zero + CBRANCH.NZ FRACTFL_1 + ; if yes, directly return + BRANCH FRACTFL_XT + + ; normalize +FRACTFL_1: + DUP + LOADCP FLOAT32_FRCMSBM ; isolate msb of fraction + AND + CBRANCH.NZ FRACTFL_2 ; skip if bit is set + ; scale left and repeat previous step + SHL ; shift fraction + LOAD FL_E_A ; decrement exponent + DEC 1 + STORE FL_E_A + BRANCH FRACTFL_1 ; repeat +FRACTFL_2: + STORE FL_F_A +FRACTFL_PK: + LOADREG FP + LOADCP _PACKFLOAT32 + CALL +FRACTFL_XT: + FPADJ FRACTFL_FS + RET + +; truncate a floating point number - return +; the integer value before the decimal point. +; issues a runtime error if the integer value +; does not fit into a signed 32-bit integer. +; parameters: float32 value +; returns: integer + .EQU TRUNCFL_SHIFT 12 + .EQU TRUNCFL_FS 16 +_TRUNCFLOAT32: + FPADJ -TRUNCFL_FS + LOADREG FP + LOADCP _UNPACKFLOAT32 + CALL + + LOAD FL_E_A ; remove bias from exponent + LOADC FLOAT32_BIAS + SUB + DUP + STORE FL_E_A + + ; if the exponent + LOADC 0 ; is negative, + CMP LT ; our result is zero + CBRANCH TRUNCFL_ZERO + + ; shift fraction all the way to the right + LOAD FL_F_A ; shift fraction right by 8 bits + BROT ; by rotating 3*8 bits left + BROT ; we know that the original bits 7-0 + BROT ; are zero + + ; calculate number of bits to shift: + ; fraction bits - 1 - exponent + LOADC FLOAT32_FRCBITS - 1 + LOAD FL_E_A + SUB + DUP + STORE TRUNCFL_SHIFT + LOADC 0 ; is shift count >= 0? + CMP GE + CBRANCH TRUNCFL_2 + + ; shift count is negative, need to shift left + ; check for integer overflow first + LOAD TRUNCFL_SHIFT + NOT ; negate shift count + INC 1 + + DUP ; shift count >= bits in a word - bits in the fraction? + LOADC 32 - FLOAT32_FRCBITS + CMP GE + CBRANCH TRUNCFL_ERR ; then we have an overflow + + ; otherwise, shift n bits left +TRUNCFL_1: + DUP + CBRANCH.Z TRUNCFL_3 ; if zero, we are done + + DEC 1 ; decrement shift count + SWAP ; swap shift count and fraction + SHL ; shift fraction left + SWAP ; swap back + BRANCH TRUNCFL_1 ; and loop + +TRUNCFL_2: ; shift right, fraction is on ToS + LOAD TRUNCFL_SHIFT ; bits to shift +TRUNCFL_L1: + DUP + CBRANCH.Z TRUNCFL_3 ; if zero, we are done + + DEC 1 ; decrement shift count + SWAP ; swap shift count and fraction + SHR ; shift fraction right + SWAP ; swap back + BRANCH TRUNCFL_L1 ; and loop +TRUNCFL_3: + DROP ; drop shift count + BRANCH TRUNCFL_EXIT +TRUNCFL_ZERO: + LOADC 0 +TRUNCFL_EXIT: + LOAD FL_S_A ; check sign + CBRANCH.Z TRUNCFL_EXIT1 + ; if not zero, negate result + NOT + INC 1 +TRUNCFL_EXIT1: + FPADJ TRUNCFL_FS + RET + +TRUNCFL_ERR: + DROP + LOADCP FLOAT32_ERR_TRUNC + LOADCP _RUNTIME_ERR + JUMP + +; like _TRUNCFLOAT32, but return a float32 value +; parameters [ float value ] +; returns: float value +; TODO: write a real routine which might be faster +; than just calling _TRUNCFLOAT32 and INTTOFLOAT32. +; Also, _TRUNCFLOAT32 can cause an integer overflow +; where INT should not. +_INTFLOAT32: + LOADCP _TRUNCFLOAT32 + CALL + LOADCP _INTTOFLOAT32 + CALL + RET + + .CPOOL + +; multiply/divide a float value by a multitude of 2 +; shift count < 1: shift right (divide) +; shuft count > 0: shift left (multiply) +; parameters: [ float value, shift count ] +; returns: float value + .EQU SHF32_FS 36 + .EQU SHF32_COUNT 12 +SHIFTFLOAT32: + FPADJ -SHF32_FS + + ; store shift count parameter + STORE SHF32_COUNT + ; Unpack float value. + ; We use the result variable slot + ; because EXP_CHECK uses that. + LOADREG FP + LOADC FL_E_R + ADD + LOADCP _UNPACKFLOAT32 + CALL + + ; we just add the shift count to + ; the exponent + LOAD FL_E_R + LOAD SHF32_COUNT + ADD + STORE FL_E_R + + ; and check for overflow + LOADCP FLOAT32_EXP_CHECK + CALL + + ; pack up the result + LOADREG FP + LOADC FL_E_R + ADD + LOADCP _PACKFLOAT32 + CALL + + FPADJ SHF32_FS + RET + +; convert an integer to a float32 +; parameters: an integer +; returns: a float32 value + .EQU INTF32_FS 12 +_INTTOFLOAT32: + FPADJ -INTF32_FS + + ; is intval zero? + DUP + CBRANCH.Z INTTOFLOAT32_XT ; if yes, we are done, float zero has the same + ; representation as integer zero + + ; is intval < 0? + LOADC 0 + CMP.S0 LT + DUP + STORE FL_S_A ; store cmp result as sign flag + CBRANCH.Z INTF32_1 ; skip negate if cmp result is 0 + ; negate + NOT + INC 1 +INTF32_1: + LOADC 30 ; set counter +INTF32_L: + ; loop if bit 31 is not set: + SWAP ; swap counter and value (value is now ToS) + + LOADCP $40000000 + AND.S0 + CBRANCH INTF32_2 + ; shift left + SHL + ; swap counter and value again (counter is now ToS) + SWAP + ; decrease counter + DEC 1 + BRANCH INTF32_L +INTF32_2: + ; store shifted value as fraction + STORE FL_F_A + ; set exponent to counter + bias + LOADC FLOAT32_BIAS + ADD + STORE FL_E_A + ; pack components + LOADREG FP + LOADCP _PACKFLOAT32 + CALL + BRANCH INTTOFLOAT32_XT +INTTOFLOAT32_XT: + FPADJ INTF32_FS + RET + +; get the binary exponent of a floating point value +; (without the bias) +; parameters: [ float value ] +; returns: exponent (-128..128) +_GETFLOAT32EXP: + LOADC FLOAT32_EXPMASK + AND + LOADC FLOAT32_BIAS + SUB + RET + +; compare an integer to a floating point value +; parameters: a:integer, b: float +; calls INTTOFLOAT32 on a, then calls CMPFLOAT32 +; returns: -1 if a < b +; 0 if a = b +_CMPINTFLOAT32: + SWAP ; swap a and b, a is now on top of stack + LOADCP _INTTOFLOAT32 + CALL ; a is now a float + SWAP ; swap a and b back, b is on top of stack again + ; fallthrough to CMPFLOAT32 + +; compare two floating point values +; parameters: two floating point values a and b +; returns: -1 if a < b +; 0 if a = b +; 1 if a > b + .EQU CMPFL_FS 24 +_CMPFLOAT32: + FPADJ -CMPFL_FS + ; unpack b + LOADREG FP + LOADC FL_E_B + ADD + LOADCP _UNPACKFLOAT32 + CALL + ;unpack a + LOADREG FP + LOADCP _UNPACKFLOAT32 + CALL + + ;if sign(a) and not sign(b): + ; return -1 + ;if not sign(a) and sign(b): + ; return 1 + LOAD FL_S_A + LOAD FL_S_B + XOR + CBRANCH.Z CMPFL_2 ; jump if signs are the same + ; signs are not the same + LOAD FL_S_A + CBRANCH.Z CMPFL_1 ; jump if a is positive + ; a is negative, b must be positive, so a < b +CMPFL_M1: + LOADC -1 + BRANCH CMPFL_XT +CMPFL_1: + ; a is positive, b must be negative, so a > b + LOADC 1 + BRANCH CMPFL_XT +CMPFL_2: + ; signs are the same, compare exponents now. + ; we can compare the exponent values directly without + ; subtracting the bias because negative exponents + ; are smaller than positive exponents due to the added + ; bias. + ; if we determine a result, from now on the result + ; must be inverted if the sign of a and b is negative. + + ;if exp(a) < exp(b): + ; return -1 * sign(a) + LOAD FL_E_A + LOAD FL_E_B + CMPU GE + CBRANCH CMPFL_3 ; jump if exp(a) >= exp(b) + ; exp(a) < exp(b), so abs(a) < abs(b) + LOADC -1 +CMPFL_2_1: + ; invert result if signs of a and b are negative + LOAD FL_S_A + CBRANCH.Z CMPFL_XT ; sign is clear, no need to invert + + NOT ; negate result and exit + INC 1 + BRANCH CMPFL_XT +CMPFL_3: + ; exp(a) >= exp(b) + ; check if exp(a) > exp(b) + LOAD FL_E_A + LOAD FL_E_B + CMPU GT + CBRANCH CMPFL_5 ; jump if yes + ; exp(a) = exp(b) + ; exponents are the same, compare fractions now + + ;if frac(a) < frac(b): + ; return -1 * sign(a) + LOAD FL_F_A + LOAD FL_F_B + CMPU GE + CBRANCH CMPFL_4 ; jump if frac(a) >= frac(b) + + ; frac(a) < frac(b) + LOADC -1 + BRANCH CMPFL_2_1 ; check for inversion of result + ;if frac(a) > frac(b): + ; return 1 * neg_result +CMPFL_4: + ; frac(a) >= frac(b) + ; check if frac(a) > frac(b) + LOAD FL_F_A + LOAD FL_F_B + CMPU GT + CBRANCH CMPFL_5 ; jump if frac(a) > frac(b) + ; frac(a) = frac(b) + LOADC 0 + BRANCH CMPFL_XT +CMPFL_5: + ; exp(a) > exp(b): + ; return 1 * sign(a) + LOADC 1 + BRANCH CMPFL_2_1 ; check for inversion of result +CMPFL_XT: + FPADJ CMPFL_FS + RET + +; Negate a float32 number. +; just flip the highest bit, no +; need to unpack. +; if it is zero, do nothing, we +; do not want a -0.0 value +_NEGFLOAT32: + DUP + CBRANCH.Z _NEGFL_XT + LOADCP $80000000 + XOR +_NEGFL_XT: + RET + + .CPOOL + +FLOAT32_ERR_OVR: + .BYTE "floating point overflow",0 +FLOAT32_ERR_TRUNC: + .BYTE "integer overflow",0 +FLOAT32_ERR_DIVZ: + .BYTE "float division by zero",0 diff --git a/lib/rommon.s b/lib/rommon.s new file mode 100644 index 0000000..a967e4b --- /dev/null +++ b/lib/rommon.s @@ -0,0 +1,805 @@ + .EQU CR 13 + .EQU LF 10 + .EQU EOT 4 + .EQU ACK 6 + .EQU NAK 21 + .EQU STX 2 + .EQU UART_REG 2048 + .EQU MON_ADDR 64512 + + BRANCH 2 ; the very first instruction is not + ; executed correctly + LOADCP 65020 ; initialise FP and RP registers + STOREREG FP + LOADCP 65024 + STOREREG RP + + LOADCP MON_ADDR + LOADCP 4096 + STOREI + DROP +CMDLOOP0: + LOADC MESSAGE + LOADC PRINTLINE + CALL + +CMDLOOP: + LOADC NEWLINE + CALL + LOADC PROMPT + CALL +CMDLOOP1: + LOADC CONIN + CALL + LOADC TOUPPER + CALL + + DUP + LOADC CONOUT + CALL + + LOADC 'A' + CMP.S0 EQ + CBRANCH.Z CMD1 + LOADC CMD_A + CALL + BRANCH CMDLOOP2 +CMD1: + LOADC 'X' + CMP.S0 EQ + CBRANCH.Z CMD2 + LOADC CMD_X + CALL + BRANCH CMDLOOP2 +CMD2: + LOADC 'D' + CMP.S0 EQ + CBRANCH.Z CMD3 + LOADC CMD_D + CALL + BRANCH CMDLOOP2 +CMD3: + LOADC 'G' + CMP.S0 EQ + CBRANCH.Z CMD4 + LOADC CMD_G + CALL + BRANCH CMDLOOP2 +CMD4: + LOADC 'L' + CMP.S0 EQ + CBRANCH.Z CMD5 + LOADC CMD_L + CALL + BRANCH CMDLOOP2 +CMD5: + LOADC 'B' + CMP.S0 EQ + CBRANCH.Z CMD6 + LOADC CMD_B + CALL + BRANCH CMDLOOP2 +CMD6: + DROP + BRANCH CMDLOOP0 +CMDLOOP2: + DROP + BRANCH CMDLOOP + +; ---- Command 'A': set current address +CMD_A: + LOADC 32 + LOADC CONOUT + CALL + LOADC READHEX + CALL + CBRANCH.Z CMD_A_INVALID ; 0 if not valid input + LOADCP MON_ADDR + SWAP + STOREI + DROP ; drop STOREI address + RET +CMD_A_INVALID: + DROP + LOADC '.' + LOADC CONOUT + CALL + RET + +; ---- Command 'X': examine current address +CMD_X: + FPADJ -8 ; reserve space for 4 bytes of local variables + LOADCP MON_ADDR + LOADI + STORE 0 ; current memory address + LOADC 4 ; print 8 words + STORE 4 ; Loop counter +CMD_X_LOOP: + LOADC 32 ; print a a space + LOADC CONOUT + CALL + LOAD 0 ; load word via current address + LOADI + LOADC PRINTHEXW ; print it + CALL + LOAD 0 + INC 4 ; increment current address + STORE 0 + LOAD 4 + DEC 1 + DUP + STORE 4 + CBRANCH.NZ CMD_X_LOOP + LOADCP MON_ADDR + LOAD 0 + STOREI + DROP + FPADJ 8 + RET + +; ---- Command 'D': deposit words at current address +CMD_D: + FPADJ -4 + LOADC 4 ; max number of words + STORE 0 +CMD_D_LOOP: + LOADC 32 ; print a space + LOADC CONOUT + CALL + LOADC READHEX + CALL + DUP + CBRANCH.Z CMD_D_EXIT ; check for invalid input + SWAP ; swap return code and value + LOADCP MON_ADDR + LOADI ; get current address + SWAP ; swap address and value for STOREI + STOREI 4 ; store the value with post-increment of address + LOADCP MON_ADDR + SWAP ; swap destination address and value for STOREI + STOREI ; store the new address + DROP + LOADC 2 ; compare return code (swapped above) to 2 + CMP EQ ; check for valid input and return key + CBRANCH CMD_D_EXIT + LOAD 0 + DEC 1 + DUP + STORE 0 + CBRANCH.NZ CMD_D_LOOP +CMD_D_EXIT: + FPADJ 4 + RET + +CMD_G: + DROP ; remove input char + LOADCP NEWLINE + CALL + LOADCP MON_ADDR + LOADI + JUMP + +CMD_L: + LOADCP NEWLINE + CALL + LOADCP RCVBLOCKS + CALL + LOADCP NEWLINE + CALL + RET + +PROMPT: + LOADC '[' + LOADC CONOUT + CALL + LOADCP MON_ADDR + LOADI + LOADC PRINTHEXW + CALL + LOADC PROMPT2 + LOADC PRINTLINE + CALL + RET + +NEWLINE: + LOADC CR + LOADC CONOUT + CALL + LOADC LF + LOADC CONOUT + CALL + RET + +; print string of byte characters +; takes pointer to string on eval stack +PRINTLINE: + DUP ; duplicate address as arg to printchar + LOADC PRINTCHAR + CALL + CBRANCH.Z PRINTLINE_EXIT ; if char is zero, exit + INC 1 ; increment address + BRANCH PRINTLINE +PRINTLINE_EXIT: + DROP ; remove address from stack + RET + +; print a single character +; takes a byte pointer on eval stack +; returns character on eval stack +PRINTCHAR: + LOADI.S1.X2Y ; load word, keep address on stack + BSEL ; select byte of a word via address + DUP ; check for null byte + CBRANCH.Z PRINTCHAR_XT + DUP + LOADC CONOUT + CALL +PRINTCHAR_XT: + RET + +; print a 32-bit hexadecimal number +; takes the value on the stack + +PRINTHEXW: + BROT + DUP + LOADC PRINTHEXB + CALL + BROT + DUP + LOADC PRINTHEXB + CALL + BROT + DUP + LOADC PRINTHEXB + CALL + BROT + LOADC PRINTHEXB + CALL + RET + +PRINTHEXB: + DUP + SHR + SHR + SHR + SHR + LOADC PRINTNIBBLE + CALL + LOADC PRINTNIBBLE + CALL + RET + +PRINTNIBBLE: + LOADC 15 + AND ; isolate nibble + LOADC 10 + CMPU.S0 GE ; nibble >= 10 ? + CBRANCH.NZ PRINTNIBBLE_1 ; then print a-f + LOADC '0' ; else print 0-9 + BRANCH PRINTNIBBLE_2 +PRINTNIBBLE_1: + LOADC 55 ; 55 + 10 == 'A' +PRINTNIBBLE_2: + ADD + LOADC CONOUT + CALL + RET + +; ------ read a 8-digit hexadecimal number from the console +; stores variables on the user stack, so the FP register must be +; inizialized. +; returns two values on the eval stack: +; - return code (topmost) +; 0 - no valid number +; 1 - valid number +; 2 - valid number and enter was pressed +; - result value + +READHEX: + FPADJ -8 + LOADC 0 ; current value + STORE 0 + LOADC 8 ; max number of digits + STORE 4 ; remaining digits counter +READHEX_1: + LOADC CONIN + CALL + LOADC CR ; RETURN pressed? + CMP.S0 EQ + CBRANCH READHEX_RT + DUP + LOADC CONOUT ; echo character + CALL + LOADC CONVHEXDIGIT + CALL + LOADC -1 + CMP.S0 EQ ; invalid character? + CBRANCH.NZ READHEX_XT + LOAD 0 + SHL 2 ; shift previous nibble + SHL 2 + OR ; combine with last digit + STORE 0 + LOAD 4 + DEC 1 + DUP + STORE 4 + CBRANCH.NZ READHEX_1 + BRANCH READHEX_XT1 +READHEX_RT: ; if no digits were entered, set return code + DROP ; drop read character + LOAD 4 ;remaining digits counter + LOADC 8 + CMP NE + CBRANCH READHEX_RT2 + LOADC 0 ; no valid input + BRANCH READHEX_XT3 +READHEX_RT2: + LOADC 2 ; valid input and return pressed + BRANCH READHEX_XT3 +READHEX_XT: + DROP + LOAD 4 + LOADC 8 + CMP EQ ; if no digits were entered + CBRANCH READHEX_XT0 +READHEX_XT1: + LOADC 1 ; valid input flag + BRANCH READHEX_XT3 +READHEX_XT0: + LOADC 0 +READHEX_XT3: + LOAD 0 + SWAP + FPADJ 8 + RET + +; ------ convert character on the eval stack to upper case +TOUPPER: + LOADC 'a' + CMP.S0 LT + CBRANCH TOUPPER_XT + LOADC 'z' + CMP.S0 GT + CBRANCH TOUPPER_XT + LOADC 32 + SUB +TOUPPER_XT: + RET + +; ------ convert hexadecimal digit to integer +; ------ takes an ascii character as parameter on the eval stack +; ------ returns an integer value from 0-15 on the eval stack, +; ------ or -1 if the character was not a valid hexadecimal digit + +CONVHEXDIGIT: + LOADC TOUPPER + CALL + LOADC '0' + CMP.S0 LT ; character < '0'? + CBRANCH.NZ CONVHEXDIGIT_ERR + LOADC '9' + CMP.S0 GT ; character > '9'? + CBRANCH.NZ CONVHEXDIGIT_ISALPHA + LOADC '0' ; character is between '0' and '9', subtract '0' + SUB + BRANCH CONVHEXDIGIT_NBL +CONVHEXDIGIT_ISALPHA: + LOADC 'A' + CMP.S0 LT ; character < 'A'? + CBRANCH.NZ CONVHEXDIGIT_ERR + LOADC 'F' + CMP.S0 GT ; character > 'F'? + CBRANCH.NZ CONVHEXDIGIT_ERR + LOADC 55 ; character is between 'A' and 'F', subtract ('A' - 10) + SUB +CONVHEXDIGIT_NBL: + RET +CONVHEXDIGIT_ERR: + DROP ; remove character from stack + LOADC -1 ; error + RET + +; --------- output a character on serial console +; --------- takes a character (padded to a word) on the eval stack +CONOUT: + LOADC UART_REG ; address of UART register + LOADI ; load status + LOADC 256 ; check bit 8 (tx_busy) + AND + CBRANCH.NZ CONOUT ; loop if bit 8 is not zero + + ; transmitter is idle now, write character + LOADC UART_REG ; address of UART register + SWAP ; swap character and address for STOREI + LOADC 1024 ; TX enable bit + OR ; OR in the character + STOREI + DROP + RET + +; ---- wait until a character is received and return it on eval stack +CONIN: + LOADC WAITFORBYTE + CALL + LOADC -1 ; -1 means timeout + CMP.S0 NE + CBRANCH CONIN_XT ; exit if no timeout + DROP ; remove last result + BRANCH CONIN +CONIN_XT: + RET + + + .EQU L_BLOCKSIZE 32 + .EQU L_WORDSIZE 4 + .EQU CKSUM_PATTERN $AFFECAFE +RCVBLOCKS: + LOADCP MON_ADDR ; pointer to current write position, + LOADI ; kept on stack +RCVBLOCKS_L: + LOADC WAITFORBYTE ; read header byte + CALL + LOADC -1 + CMP.S0 EQ + CBRANCH RCVBLOCKS_XT ; exit on timeout + + ; check for EOT -> end + LOADC EOT + CMP.S0 EQ + CBRANCH RCVBLOCKS_XT + + ; check for STX -> read block + LOADC STX + CMP.S0 EQ + CBRANCH RCVBLOCKS_CONT + + ; anything else -> send NAK + BRANCH RCVBLOCKS_RETRY + +RCVBLOCKS_CONT: + DROP ; remove header byte + DUP ; duplicate pointer + LOADC READBLOCK + CALL + LOADC -1 + CMP.S0 EQ ; check for timeout + CBRANCH RCVBLOCKS_XT ; exit on timeout + + LOADC -2 + CMP.S0 EQ ; check for checksum error + CBRANCH RCVBLOCKS_RETRY + + DROP ; remove return code + LOADC L_BLOCKSIZE ; advance pointer + ADD + + LOADC ACK ; send ACK + LOADC CONOUT + CALL + + ; next block + BRANCH RCVBLOCKS_L + +RCVBLOCKS_RETRY: + DROP ; remove read byte + ; send NAK + LOADC NAK + LOADC CONOUT + CALL + + ; next block + BRANCH RCVBLOCKS_L + +RCVBLOCKS_XT: + DROP ; remove pointer + DROP ; remove read byte + RET + + +; ---- read a sequence of binary words and store into memory +; - arguments: pointer to memory area +READBLOCK: + FPADJ -12 + STORE 0 ; buffer pointer + LOADCP L_BLOCKSIZE + STORE 4 ; remaining bytes + LOADC 0 + STORE 8 ; checksum +READBLOCK_L: + LOADCP READWORD ; read a word + CALL + LOADC -1 ; check for timeout + CMP EQ + CBRANCH.NZ READBLOCK_ERR + + ; DUP ; debug + ; LOADC PRINTHEXW + ; CALL + + + DUP ; duplicate read word + LOAD 8 ; load checksum + ADD ; checksum = ((checksum + data) ^ pattern) << 1 + LOADCP CKSUM_PATTERN + XOR + SHL + STORE 8 ; store new checkcsum + + LOAD 0 ; load buffer pointer + SWAP ; swap value and pointer for STOREI + STOREI 4 ; store word and increment pointer + STORE 0 ; store pointer + + LOAD 4 ; load remaining bytes + DEC L_WORDSIZE ; decrement by word size + DUP + STORE 4 ; store + CBRANCH.NZ READBLOCK_L ; loop if remaining words not zero + + + LOADCP READWORD ; read checksum + CALL + LOADC -1 ; check for timeout + CMP EQ + CBRANCH READBLOCK_ERR + + LOAD 8 ; load checksum + CMP EQ + CBRANCH READBLOCK_OK + LOADC -2 ; return code for checksum error + BRANCH READBLOCK_XT +READBLOCK_OK: + LOADC 0 ; return 0 +READBLOCK_XT: + FPADJ 12 + RET + +READBLOCK_ERR: + DROP ; remove result + LOAD 4 ; return number of missing bytes + FPADJ 8 + RET + +; --- read four bytes (msb to lsb) and return as word +; returns: word, error code (-1 for error, 0 otherwise) + +READWORD: + LOADCP WAITFORBYTE + CALL + DUP + LOADC -1 ; check for error + CMP EQ + CBRANCH.NZ READWORD_ERR + ; first byte is now on stack + BROT ; rotate byte left + + LOADCP WAITFORBYTE + CALL + DUP + LOADC -1 ; check for error + CMP EQ + CBRANCH.NZ READWORD_ERR + ; second byte is now on stack + OR ; OR last byte with this byte + BROT ; rotate bytes left + + LOADCP WAITFORBYTE + CALL + DUP + LOADC -1 ; check for error + CMP EQ + CBRANCH.NZ READWORD_ERR + ; third byte is now on stack + OR ; OR last byte with this byte + BROT + + LOADCP WAITFORBYTE + CALL + DUP + LOADC -1 ; check for error + CMP EQ + CBRANCH.NZ READWORD_ERR + ; fourth byte is now on stack + OR ; OR last byte with this byte + + LOADC 0 ; error code (0: no error) + RET + +READWORD_ERR: + LOADC -1 ; error code + RET + +;---- wait a fixed amount of cycles for a character to be +; received on the UART. +; returns character or -1 on timeout + + .EQU MAX_WAIT 20000000 +WAITFORBYTE: + LOADCP MAX_WAIT ; maximum wait loops +WAITFORBYTE_L: + LOADC UART_REG ; address of UART register + LOADI ; load status + LOADC 512 ; check bit 9 (rx_avail) + AND + CBRANCH WAITFORBYTE_RX ; if bit 9 is one, a character is available + DEC 1 + DUP + CBRANCH.NZ WAITFORBYTE_L + DROP ; remove wait counter from stack + LOADC -1 ; error code + RET +WAITFORBYTE_RX: + DROP ; remove wait counter from stack + LOADC UART_REG + LOADI ; read register again + LOADC 255 ; mask status bits + AND + LOADC UART_REG ; I/O address + LOADC 512 ; set bit 9 (rx_clear) + STOREI ; write register + DROP ; remove address left by STOREI + RET + + .CPOOL + +;---- boot from SD-card + + ; declare buffer addresses used by sdcardlib.s + .EQU CSD_BUF 63984 + .EQU CARD_BUF 64000 +CMD_B: + DROP ; remove input char + LOADCP NEWLINE + CALL + + FPADJ -4 + ; initialize card + LOADC INITSDCARD + CALL + + ; read partition block + LOADC 0 + LOADC CARDREADBLK + CALL + + DUP ; non-zero return code means error + CBRANCH.Z CMD_B_1 +CMD_B_ERR: + LOADC PRINTHEXW ; print error code + CALL + LOADC NEWLINE + CALL + LOADC 0 ; if we return, we need to + ; put a fake input char back on the + ; stack because the main loop will + ; try to remove it + FPADJ 4 + RET + +CMD_B_1: + DROP ; remove error code + ; check boot partition slot (boot flag) + LOADCP CARD_BUF,104 ; offset partition flags second part slot + LOADI + LOADC 2 ; PartFlags [PartBoot] + CMP EQ + CBRANCH CMD_B_C + + ; no boot partition + LOADC $B0 + BRANCH CMD_B_ERR + +CMD_B_C: + ; get start block + LOADCP CARD_BUF,108 ; offset startBlock + LOADI + ; get block count + LOADCP CARD_BUF,124 ; offset bootBlocks + LOADI + + FPADJ -4 ; allocate space for address var + LOADCP MON_ADDR + LOADI + STORE 0 ; initialize dest addr +CMD_B_L: + ; read block + OVER ; duplicate block no + LOADC CARDREADBLK + CALL + + DUP ; check for error + CBRANCH.Z CMD_B_C2 ; continue if zero (no error) + + NIP ; remove start and count, keep error code + NIP + BRANCH CMD_B_ERR +CMD_B_C2: DROP ; remove error code +CMD_B_2: + ; copy to destination + LOAD 0 ; dest addr + LOADC COPY_BLK + CALL + + ; decrement count and loop + LOAD 0 ; increment dest addr + LOADC 512 + ADD + STORE 0 + + SWAP ; swap block no/count, blockno is now ToS + INC 1 + SWAP ; count is now ToS + DEC 1 + DUP + CBRANCH.NZ CMD_B_L ; if not zero, loop + + ; jump to coreloader + DROP + DROP + FPADJ 4 + LOADCP MON_ADDR + LOADI + JUMP + +CMD_B_XT: + FPADJ 4 + RET + +; copy a sdcard block to destination address +; block size is always 512 byte, source +; is always CARD_BUF +; parameters: dest addr +COPY_BLK: + FPADJ -4 + LOADC 128 ; word count + STORE 0 + + LOADCP CARD_BUF ; src addr +COPY_BLK1: + SWAP + ; [ src addr, dest addr ] + OVER ; [ saddr, daddr, saddr ] + LOADI ; [ saddr, daddr, sword ] + STOREI 4 ; [ saddr, daddr + 4 ] + SWAP ; [ daddr + 4, saddr ] + INC 4 ; [ daddr + 4, saddr + 4] + + LOAD 0 ; load and decrement counter + DEC 1 + DUP + STORE 0 ; store it again + CBRANCH.NZ COPY_BLK1 ; if not zero, loop + + DROP ; remove saddr and daddr + DROP + + FPADJ 4 + RET + + .CPOOL + +; wait approx. 1 millisecond +; +; 83.333 MHz Clock, three instructions a 4 cycles +; 83333 / 12 = 6944.4166 +; works only if executed without wait states (i.e. +; from BRAM/SRAM) +WAIT1MSEC: + LOADCP 6944 +WAIT1LOOP: + DEC 1 + DUP + CBRANCH.NZ WAIT1LOOP + DROP + RET + +%include "sdcardboot.s" + .CPOOL +MESSAGE: + .BYTE 13,10,"ROM Monitor v3.0.3", 13, 10, + "Set A)ddress D)eposit eX)amine L)oad G)o B)oot",13,10,0 +PROMPT2: + .BYTE "]> ",0 +END: diff --git a/lib/runtime.s b/lib/runtime.s new file mode 100644 index 0000000..e7c43ce --- /dev/null +++ b/lib/runtime.s @@ -0,0 +1,1939 @@ +; Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details + .EQU LOADER_START 4096 + + .EQU STRM_FS 16 + .EQU STRM_PTR 0 + .EQU STRM_IDX 4 + .EQU STRM_LEN 8 + .EQU STRM_DELTA 12 + +; copy bytes inside a pascal string, moving up +; args: string ptr, index, length, delta +STRMOVEUP: + FPADJ -STRM_FS + STORE STRM_DELTA + STORE STRM_LEN + STORE STRM_IDX + STORE STRM_PTR + + + LOADCP STRM_CHKARGS + CALL + CBRANCH.Z STRMU_XT + + ; args are ok, call _BMOVEUP + ; offset + LOAD STRM_DELTA + ; src + LOAD STRM_IDX + DEC 1 ; adjust for base 1 + LOAD STRM_PTR + INC 8 ; skip string header + ADD + ; count + LOAD STRM_LEN + + LOADCP _BMOVEUP + CALL +STRMU_XT: + FPADJ STRM_FS + RET + +; check args for STRMOVEUP and STRMOVEDOWN +; shares stack frame with caller +; returns 0 if args are invalid +STRM_CHKARGS: ; check if length or index are negative + LOAD STRM_LEN + LOADC 0 + CMP LE + CBRANCH STRMC_XT + + LOAD STRM_IDX + LOADC 0 + CMP LE + CBRANCH STRMC_XT + + LOAD STRM_DELTA + LOADC 1 + CMP LT + CBRANCH STRMC_XT + + ; check if index + len + delta < string end + LOAD STRM_PTR + LOADI ; get string size + + LOAD STRM_IDX + LOAD STRM_DELTA + ADD + LOAD STRM_LEN + ADD + DEC 1 ; adjust for base 1 + + CMP LT + CBRANCH STRMC_XT + + LOADC 1 + RET +STRMC_XT: + LOADC 0 + RET + +; copy bytes inside a pascal string, moving down +; index is the destination, index + delta the source +; args: string ptr, index, length, delta +STRMOVEDOWN: + FPADJ -STRM_FS + STORE STRM_DELTA + STORE STRM_LEN + STORE STRM_IDX + STORE STRM_PTR + + LOADCP STRM_CHKARGS + CALL + CBRANCH.Z STRMD_XT + + ; args are ok, call _BMOVEDOWN + ; offset + LOAD STRM_DELTA + ; src + LOAD STRM_IDX + DEC 1 ; adjust for base 1 + LOAD STRM_PTR + INC 8 ; skip string header + ADD + ; count + LOAD STRM_LEN + + LOADCP _BMOVEDOWN + CALL +STRMD_XT: + FPADJ STRM_FS + RET + +; copy bytes from src to src + offset, moving +; upwards. the copied byte ranges may overlap. +; count and offset must be > 0 +; args: offset, src, count + .EQU BMU_COUNT 0 + .EQU BMU_SRC 4 + .EQU BMU_OFFS 8 + .EQU BMU_FS 12 +_BMOVEUP: + FPADJ -BMU_FS + DUP + STORE BMU_COUNT + DEC 1 + ADD ; store end of source range + STORE BMU_SRC + STORE BMU_OFFS + + ; copy bytes from end to start, descending + LOAD BMU_COUNT ; keep count on stack for the loop +_BMU_L: + + LOAD BMU_SRC + LOAD BMU_OFFS + ADD ; dest addr = src + offs + LOADI.S1.X2Y ; [ dest, word ] + OVER ; [ dest, word, dest ] + LOADC $FF ; [ dest, word, dest, $FF] + BPLC + NOT ; [ dest, word, mask ] + AND ; [ dest, masked word ] + + OVER ; [ dest, masked, dest ] + LOAD BMU_SRC ; [ dest, masked, dest, src ] + LOADI.S1.X2Y ; [ dest, masked, dest, src, src word ] + BSEL ; [ dest, masked, dest, src byte ] + BPLC ; [ dest, masked, dest byte ] + OR ; [ dest, dest word ] + STOREI + DROP + + DEC 1 + DUP + CBRANCH.Z _BMU_X + LOAD BMU_SRC + DEC 1 + STORE BMU_SRC + BRANCH _BMU_L +_BMU_X: + DROP + FPADJ BMU_FS + RET + +; copy bytes from dest + offset to dest, moving +; downwards. the copied byte ranges may overlap. +; count and offset must be > 0 +; args: offset, dest, count + .EQU BMD_COUNT 0 + .EQU BMD_DEST 4 + .EQU BMD_OFFS 8 + .EQU BMD_FS 12 +_BMOVEDOWN: + FPADJ -BMD_FS + STORE BMD_COUNT + STORE BMD_DEST + STORE BMD_OFFS + + ; copy bytes from start to end + LOAD BMU_COUNT ; keep count on stack for the loop +_BMD_L: + LOAD BMD_DEST ; [ dest ] + LOADI.S1.X2Y ; [ dest, dest word ] + OVER ; [ dest, word, dest ] + LOADC $FF + BPLC + NOT ; [ dest, word, mask ] + AND ; [ dest, masked word ] + OVER ; [ dest, masked word, dest ] + + DUP + LOAD BMD_OFFS + ADD ; src addr = dest + offs + LOADI.S1.X2Y ; get source word + BSEL ; get source byte + ; stack now: [ dest, masked word, dest, source byte ] + BPLC ; [ dest, masked word, rotated byte ] + OR ; [ dest, new word ] + STOREI + DROP + + DEC 1 + DUP + CBRANCH.Z _BMD_X + LOAD BMD_DEST + INC 1 + STORE BMD_DEST + BRANCH _BMD_L +_BMD_X: + DROP + FPADJ BMD_FS + RET + +; copy bytes between two arrays of words +; no bounds check is performed +; parameters: [ dest, destoffset, src, srcoffset, length ] + .EQU CPB_LEN 0 + .EQU CPB_DPTR 4 + .EQU CPB_SPTR 8 + .EQU CPB_FS 12 +COPYBUF: + FPADJ -CPB_FS + STORE CPB_LEN + ADD ; add src and srcoffset + STORE CPB_SPTR + ADD ; add dest and destoffset + STORE CPB_DPTR + + ; check if source ptr and dest prtr + ; are word-aligned + LOAD CPB_SPTR + LOAD CPB_DPTR + OR + LOADC 3 + AND + CBRANCH COPYBYTES ; if not, continue with COPYBYTES + +COPYBUF_1: + LOAD CPB_LEN ; check if length is smaller than + LOADC 4 ; word size + CMP LT + CBRANCH COPYBYTES ; if yes, continue with COPYBYTES + + ; else copy whole words + LOAD CPB_DPTR + LOAD CPB_SPTR + LOAD CPB_LEN + SHR ; COPYWORDS needs number of words, not bytes + SHR ; so divide by 4 + LOADCP _COPYWORDS + CALL + + ; calculate remaining bytes + LOAD CPB_LEN + DUP ; duplicate for offset calculation below + LOADC 3 + AND ; get lower two bits for remaining byte count + DUP + CBRANCH.Z COPYBUF_XT ; if zero remaining, exit + STORE CPB_LEN ; store as new length + LOADC ~3 ; calculate length rounded down to word size + AND ; by setting lower two bits to zero + DUP ; duplicate it to calculate two offsets + LOAD CPB_DPTR + ADD + STORE CPB_DPTR ; move dest ptr to remaining bytes + LOAD CPB_SPTR + ADD + STORE CPB_SPTR ; move src ptr to remaining bytes + BRANCH COPYBYTES + +COPYBUF_XT: + DROP ; cleanup stack + DROP + FPADJ CPB_FS + RET + +; Copy single bytes, branch from COPYBUF +COPYBYTES: + LOAD CPB_LEN ; put counter on stack +COPYBYTES_L: + DUP ; check if remaining length is 0 + CBRANCH.Z COPYBYTES_XT ; exit loop if true + LOAD CPB_DPTR ; load dest ptr for SETSTRINGCHAR below + INC.S1.X2Y 1 ; increment dest ptr and keep old value + STORE CPB_DPTR ; store incremented dest ptr, old value is now ToS + LOAD CPB_SPTR ; load src ptr + INC.S1.X2Y 1 ; increment src ptr and keep old value + STORE CPB_SPTR ; store incremented src ptr, old value is now ToS + LOADI.S1.X2Y ; load source word, keep addr + BSEL ; select byte from word via addr + LOADCP _SETSTRINGCHAR ; put byte into destination + CALL + DEC 1 ; decrement counter + BRANCH COPYBYTES_L +COPYBYTES_XT: + DROP ; remove counter + FPADJ CPB_FS + RET + +; helper routine to read a char from a file +; parameters: [ pointer to file record ] +READFSCHAR: + LOADCP READFSCHARBUF + LOADC 1 ; length arg + LOADCP READFS + CALL + + LOADC 0 ; byte address for BSEL + LOADCP READFSCHARBUF + LOADI + + BSEL ; get the most significant byte + RET + +READFSCHARBUF: + .WORD 0 + +; helper routine to write a byte to a file +; parameters: [ pointer to file record, char value ] +WRITEFSCHAR: + BROT ; rotate char value to MSB + BROT + BROT + LOADCP WRITEFSCHARBUF + SWAP + STOREI ; store rotated value to buffer + ; keep address on stack (WRITEFSCHARBUF) + LOADC 1 ; length arg + LOADCP WRITEFS + JUMP ; save one RET + +WRITEFSCHARBUF: + .WORD 0 + +; helper routine to write a string to a file +; parameters: pointer to file record, string pointer +WRITEFSSTRING: + DUP ; duplicate string ptr + INC 8 ; skip string header + SWAP ; put original string ptr on ToS + LOADI ; load length from string header + ; stack is now [ ptr to file, string ptr+8, length ] + LOADCP WRITEFS + JUMP +; write a number of words to a channel +; parameters: [ ptr to file record, word pointer, word count ] +WRITECHANWORDS: + ; we ignore the file record since there is only + ; one device for now + DUP + CBRANCH.Z WRITECHANW_XT ; if count is zero, exit + DEC 1 ; decrement counter + SWAP ; swap counter and word ptr + LOADI.S1.X2Y ; load word, keep addr + LOADCP CONOUTW + CALL + INC 4 ; increment addr + SWAP ; swap back word ptr and counter + BRANCH WRITECHANWORDS +WRITECHANW_XT: + DROP + DROP + DROP + RET + + +; read a number of words from a channel +; parameters: [ ptr to file record, destination pointer, word count ] +READCHANWORDS: + ; we ignore the file record since there is only + ; one device for now + DUP + CBRANCH.Z WRITECHANW_XT ; if count is zero, exit + DEC 1 ; decrement counter + SWAP ; swap counter and word ptr + LOADCP CONINW ; read four bytes + CALL + STOREI 4 ; store and post-increment + SWAP ; swap back word ptr and counter + BRANCH READCHANWORDS +READCHANW_XT: + DROP + DROP + DROP + RET + +; --- check if a string is already initialized +; parameters: addr +; returns: 1 if it is initialied, 0 otherwise +_STRINGISINITED: + LOADI.S1.X2Y ; load length field, keep addr + CBRANCH.NZ STRIN_XT1 ; if not zero, it is already inited + INC 4 ; increment addr for max length field + LOADI + CBRANCH.NZ STRIN_XT2 ; if not zero, already initialized + LOADC 0 ; return 0 + RET +STRIN_XT1: + DROP ; remove addr +STRIN_XT2: + LOADC 1 ; return 1 + RET + +; --- initialise a string if it is not already initialized +; parameters: [ length, addr ] +_INITSTRING: + DUP + LOADCP _STRINGISINITED + CALL ; check if string is already initialized + CBRANCH.Z _INITSTRINGF + DROP ; if yes, drop args and return immediately + DROP + RET + +; --- initialise a string, do not check if it is already +; initialized. +; parameters: [ length, addr ] +_INITSTRINGF: + LOADC 0 ; [ length, addr, 0 ] + STOREI 4 ; set length to 0, store with post-increment [ length, addr + 4 ] + SWAP ; swap addr and length [ addr + 4, length ] + STOREI 4; store max length, post-increment addr by 4 [ addr + 8 ] + LOADC 0 ; [addr + 8, 0 ] + STOREI ; zero first word [ addr + 8 ] + DROP ; drop addr from STOREI + RET + +; --- initialise string from another +; parameters: [ dest, src, length ] +_INITSTRINGFROM: + FPADJ -4 + STORE 0 ; [ dest, src ] + OVER ; [ dest, src, dest ] + LOAD 0 ; [ dest, src, dest, length ] + SWAP ; [ dest, src, length, dest ] + LOADCP _INITSTRINGF + CALL ; [ dest, src ] + LOADCP _COPYSTRING + CALL ; [ ] + FPADJ 4 + RET + +; --- copy a pascal string to another +; parameters: [ dest, src ] + .EQU CPSTR_DST 0 + .EQU CPSTR_SRC 4 + .EQU CPSTR_DSTMAX 8 + .EQU CPSTR_SRCLEN 12 + .EQU CPSTR_FS 16 +_COPYSTRING: + FPADJ -CPSTR_FS + SWAP ; get dest addr first + DUP ; dup pointer for LOADI + STORE CPSTR_DST ; destination pointer + INC 4 ; increment pointer + LOADI ; load max length of destination + STORE CPSTR_DSTMAX ; and store into local var + DUP ; dup src pointer for LOADI + STORE CPSTR_SRC ; source pointer + LOADI ; load length of source + DUP ; duplicate length for CMPU below + STORE CPSTR_SRCLEN ; and store into local var + LOAD CPSTR_DSTMAX ; if dest max size is zero, + CBRANCH.NZ CPSTR_0 ; throw a runtime error + LOADCP _ERRMSG_CONSTWR + LOADCP _RUNTIME_ERR + JUMP +CPSTR_0: + LOAD CPSTR_DSTMAX + ; if dest.max_length < src.length, use dest.max_length as src.length + CMPU LE ; src.length <= dest.max_length? + CBRANCH CPSTR_1 + LOAD CPSTR_DSTMAX + STORE CPSTR_SRCLEN +CPSTR_1: + ; set dest.length to src.length + LOAD CPSTR_DST ; load dst addr + DUP ; dup for INC/STORE below + LOAD CPSTR_SRCLEN + STOREI ; store src length to dst length + DROP ; drop addr from STOREI + INC 8 ; skip length and max length words + STORE CPSTR_DST + LOAD CPSTR_SRC ; skip length and max length words + INC 8 + STORE CPSTR_SRC + + ; copy ((src.length+3) div 4) words from src to dest + LOAD CPSTR_SRCLEN ; calculate number of words + LOADC 3 + ADD + SHR + SHR +CPSTR_L1: + DUP ; duplicate word counter + CBRANCH.Z CPSTR_LE ; if it is zero, exit loop + LOAD CPSTR_DST ; load dst addr for STOREI below + LOAD CPSTR_SRC ; load src addr + LOADI ; load value + STOREI 4 ; store value, increment dst addr + STORE CPSTR_DST ; store new dst addr + LOAD CPSTR_SRC + INC 4 ; increment src addr + STORE CPSTR_SRC ; and store it + DEC 1 ; decrement word counter + BRANCH CPSTR_L1 +CPSTR_LE: + ; mask bytes in last word depending on length modulo 4: + ; 0: $00000000 + ; 1: $FF000000 + ; 2: $FFFF0000 + ; 3: $FFFFFF00 + LOAD CPSTR_DST + DEC 4 ; get pointer to last word + LOADI.X2Y.S1 ; load value of last word, keep addr + LOAD CPSTR_SRCLEN ; length of string + LOADC 3 + AND ; modulo 4 + SHL 2 ; *4 + LOADCP CPSTR_MASK ; + addr of mask table + ADD + LOADI ; load mask value + AND + STOREI ; store masked value + DROP ; remove addr from STOREI + DROP ; drop word counter +CPSTR_XT: + FPADJ CPSTR_FS + RET +CPSTR_MASK: + .WORD $FFFFFFFF, $FF000000, $FFFF0000, $FFFFFF00 + + .CPOOL + +; --- append a pascal string to another +; parameters: [ dest, src ] +_APPENDSTRING: + .EQU APSTR_SRCLEN 0 + .EQU APSTR_DSTLEN 4 + .EQU APSTR_SRC 8 + .EQU APSTR_DST 12 + .EQU APSTR_DSTMAX 16 + .EQU APSTR_FS 20 + FPADJ -APSTR_FS + LOADI.X2Y.S1 ; load src length, keep addr + STORE APSTR_SRCLEN ; store it to local var + INC 8 ; increment addr to point to first char/word + STORE APSTR_SRC ; store it to local var + LOADI.X2Y.S1 ; load dest length, keep addr + STORE APSTR_DSTLEN ; store it to local var + INC 4 ; increment addr to point to dest max length + LOADI.X2Y.S1 ; load it, keep addr + STORE APSTR_DSTMAX ; store it to local var + INC 4 ; increment addr to point to first char/word + STORE APSTR_DST ; store it to local var + + LOAD APSTR_DSTMAX ; if dest max size is zero, + CBRANCH.NZ APSTR_0 ; throw a runtime error + LOADCP _ERRMSG_CONSTWR + LOADCP _RUNTIME_ERR + JUMP + +APSTR_0: + ; if src.length + dest.length <= dest.maxlength + ; use src.length as number of characters + ; else + ; use dest.maxlength - dest.length as number of characters + + LOAD APSTR_SRCLEN ; char counter + DUP + LOAD APSTR_DSTLEN + ADD + LOAD APSTR_DSTMAX + CMPU LE + CBRANCH APSTR_1 + DROP ; drop char counter + LOAD APSTR_DSTMAX + LOAD APSTR_DSTLEN + SUB ; calculate dest.maxlength - dest.length as char counter +APSTR_1: + ; set dest.length to dest.length + number of characters + LOAD APSTR_DST + DEC 8 ; get pointer to dest.length for STOREI + OVER ; duplicate char counter + LOAD APSTR_DSTLEN + ADD ; dest.length = dest.length + char counter + STOREI + DROP ; drop STOREI addr, char counter is now on top of stack + ; set dest pointer to start + dest.length + LOAD APSTR_DST + LOAD APSTR_DSTLEN + ADD + STORE APSTR_DST +APSTR_L0: + ; while number of characters > 0: + DUP ; duplicate number of remaining characters + CBRANCH.Z APSTR_3 ; if zero, exit loop + DEC 1 ; decrement char counter + + ; load src value, byte select by src addr + LOAD APSTR_SRC + LOADI.X2Y.S1 + BSEL + LOAD APSTR_DST ; load dest pointer + LOADCP APPENDCHAR_U + CALL + + ; increment src and dest pointer + LOAD APSTR_DST + INC 1 + STORE APSTR_DST + LOAD APSTR_SRC + INC 1 + STORE APSTR_SRC + BRANCH APSTR_L0 +APSTR_3: + DROP ; remove char counter + FPADJ APSTR_FS + RET + +; write four bytes from a word to console, msb first +; parameters: [ word value ] +CONOUTW: + BROT ; rotate msb to lsb + DUP + LOADC 255 ; mask out all other bytes + AND + LOADCP CONOUT + CALL + + BROT ; rotate msb to lsb + DUP + LOADC 255 + AND + LOADCP CONOUT + CALL + + BROT ; rotate msb to lsb + DUP + LOADC 255 + AND + LOADCP CONOUT + CALL + + BROT ; rotate msb to lsb + LOADC 255 + AND + LOADCP CONOUT + CALL + + RET + +; read four bytes from console to a word +; returns word on estack +CONINW: + LOADCP CONIN + CALL + + BROT + LOADCP CONIN + CALL + OR + + BROT + LOADCP CONIN + CALL + OR + + BROT + LOADCP CONIN + CALL + OR + RET + +; put a byte-sized character into a word. +; this is a utility route for APPENDSTRING, no bounds checking is done. +; bytes in the word after this character are cleared. +; example: destination word is 'ABCD', addr points to word addr +1, +; character is 'X', result: word contains 'AX\0\0' +; parameters [ character, byte pointer ] +APPENDCHAR_U: + FPADJ -4 + DUP + STORE 0 + SWAP ; [ ptr, char ] + BPLC ; [ rotated char ] + LOAD 0 ; [ rot char, ptr ] + LOADI ; load word value + LOAD 0 ; calculate mask value by addr modulo 4 + LOADC 3 + AND + SHL 2 + LOADCP _APPENDMASK + ADD + LOADI ; load mask + AND ; mask word + + OR ; OR masked dest value with rotated char value + LOAD 0 ; get word addr again + SWAP ; swap for STOREI + STOREI + DROP ; remove addr from STOREI + FPADJ 4 + RET +_APPENDMASK: .WORD $00000000, $FF000000, $FFFF0000, $FFFFFF00 + +; Append a character to a pascal string. +; parameters: [ string ptr, char value ] +; Does a bounds check, so it can be called from Pascal. +APPENDCHAR: + SWAP ; put string ptr first + LOADI.S1.X2Y ; get current length, keep ptr + OVER + INC 4 + LOADI ; get maximum length + CMPU LT ; if current length > max length, we can add a character + CBRANCH.NZ APPENDCHAR_1 + + ;if not, check for attempt to write to a string constant + ; (which has max length 0) + NIP ; we don't need the char value anymore, the string ptr is ToS + INC 4 ; last time we use str ptr, so no DUP + LOADI ; get max length + CBRANCH.NZ APPENDCHAR_0 + + LOADCP _ERRMSG_CONSTWR + LOADCP _RUNTIME_ERR + JUMP +APPENDCHAR_0: + ; if the string is already at max length, + ; we do nothing, analogous to the + operator + RET + +APPENDCHAR_1: ; on stack here: [ char value, str ptr ] + ; calculate byte ptr from str ptr + LOADI.S1.X2Y ; get length, keep str ptr + INC 1 ; increase length by 1 + STOREI ; store new length + LOADI.S1.X2Y ; load it again; keep ptr + ADD ; add length to str ptr + INC 8-1 ; byte ptr starts at 0, so adjust for header size - 1 + LOADCP APPENDCHAR_U + JUMP + +; compare two pascal strings for equality. +; the last word must be padded with null bytes +; if string length is not divisible by 4 +; (which is ensured by _INITSTRING/APPENDSTRING). +; parameters: [ string1, string2 ] +; returns: 0 if not equal, 1 if equal +_CMPSTRING: + .EQU CMPSTR_S1 0 + .EQU CMPSTR_S2 4 + .EQU CMPSTR_FS 8 + FPADJ -CMPSTR_FS + STORE CMPSTR_S2 ; store s2 string pointer + STORE CMPSTR_S1 ; store s1 string pointer + LOAD CMPSTR_S1 + LOADI ; load s1.length + LOAD CMPSTR_S2 + LOADI ; load s2.length + CMPU NE ; if string lengths are not the same, + CBRANCH CMPSTR_XT_NE1 ; strings are not equal + + LOAD CMPSTR_S1 + LOADI.X2Y.S1 ; load s1 length again, keep addr + INC 3 ; calculate number of words to compare: + SHR ; count = (length + 3) div 4 + SHR + SWAP ; put addr on top + INC 8 ; increment addr to skip length fields + STORE CMPSTR_S1 ; store new addr + LOAD CMPSTR_S2 ; skip length fields for s2 pointer too + INC 8 + STORE CMPSTR_S2 + ; word counter is now on top of stack +CMPSTR_L0: + DUP ; if word counter is zero, strings are equal + CBRANCH.Z CMPSTR_XT_EQ + LOAD CMPSTR_S1 ; load current word of s1 and s2 + LOADI + LOAD CMPSTR_S2 + LOADI + CMPU NE + CBRANCH CMPSTR_XT_NE ; if not equal, strings are not equal + LOAD CMPSTR_S1 ; increment s1 pointer + INC 4 + STORE CMPSTR_S1 + LOAD CMPSTR_S2 ; increment s2 pointer + INC 4 + STORE CMPSTR_S2 + DEC 1 ; decrement word counter + BRANCH CMPSTR_L0 ; loop +CMPSTR_XT_EQ: + DROP ; remove word counter + LOADC 1 ; return 1 + BRANCH CMPSTR_XT +CMPSTR_XT_NE: + DROP ; remove word counter +CMPSTR_XT_NE1: + LOADC 0 ; return 0 +CMPSTR_XT: + FPADJ CMPSTR_FS + RET + +; compare two pascal strings lexicographically +; parameters: [ pointer to string a, pointer to string b ] +; returns: -1 if a < b, 0 if a = b, 1 if a > b +; NOTE: does not really do a lexicographic comparison, but +; a byte-wise numeric comparison. this works for ascii +; but not for other characters like umlauts etc. +; requires that the unused bytes in the last word +; are set to zero (which is guaranteed by _INITSTRING +; and APPENDSTRING). + + .EQU CMPSTRL_A_COUNT 0 + .EQU CMPSTRL_B_COUNT 4 + .EQU CMPSTRL_A 8 + .EQU CMPSTRL_B 12 + .EQU CMPSTRL_OFFS 16 + .EQU CMPSTRL_RESULT 20 + .EQU CMPSTRL_FS 24 +_CMPSTRINGL: + FPADJ -CMPSTRL_FS + STORE CMPSTRL_B + STORE CMPSTRL_A + LOAD CMPSTRL_A ; load ptr to A + LOADI ; get length field + INC 3 ; add wordsize - 1 + SHR + SHR ; divide by 4 to get length in words + STORE CMPSTRL_A_COUNT + LOAD CMPSTRL_B ; load ptr to B + LOADI ; get length field + INC 3 ; add wordsize - 1 + SHR + SHR ; divide by 4 to get length in words + STORE CMPSTRL_B_COUNT + + LOADC 8 + STORE CMPSTRL_OFFS ; offset for both strings, start after string header + +CMPSTRL_L: ; loop start + LOAD CMPSTRL_A_COUNT + CBRANCH.NZ CMPSTRL_1 ; if word count A if zero: + LOAD CMPSTRL_B_COUNT + CBRANCH.NZ CMPSTRL_1A ; and word count B is zero, + LOADC 0 + BRANCH CMPSTRL_XT ; strings are equal +CMPSTRL_1A: + ; word count A is zero, word count B is not zero: A < B + LOADC -1 + BRANCH CMPSTRL_XT +CMPSTRL_1: + LOAD CMPSTRL_B_COUNT + CBRANCH.NZ CMPSTRL_2 ; if word count B is zero (and word count A cannot be zero here) + LOADC 1 + BRANCH CMPSTRL_XT ; A > B +CMPSTRL_2: ; both strings have remaining words to compare here + LOAD CMPSTRL_OFFS + LOAD CMPSTRL_A ; word address = A ptr + offset + ADD + LOADI ; load word from A + LOAD CMPSTRL_OFFS ; word address = B ptr + offset + LOAD CMPSTRL_B + ADD + LOADI ; load word from B + OVER + OVER ; duplicate both words + CMPU LT ; check if word from A < word from B + CBRANCH.Z CMPSTRL_2A + DROP + DROP + LOADC -1 ; result code for A < B + BRANCH CMPSTRL_XT +CMPSTRL_2A: + CMPU GT ; check if word from A > word from B + CBRANCH CMPSTRL_2B + ; nope, they are equal + ; continue loop: decrease counters, increase offset + LOAD CMPSTRL_A_COUNT + DEC 1 + STORE CMPSTRL_A_COUNT + LOAD CMPSTRL_B_COUNT + DEC 1 + STORE CMPSTRL_B_COUNT + LOAD CMPSTRL_OFFS + INC 4 + STORE CMPSTRL_OFFS + BRANCH CMPSTRL_L +CMPSTRL_2B: + LOADC 1 ; result code for A > B +CMPSTRL_XT: + FPADJ CMPSTRL_FS + RET + + .CPOOL + +; create a string from a character +; requires a pointer to a buffer of 12 bytes (minimum string buffer size) +; parameters: [ char value, pointer to string buffer ] +_CHARTOSTRING: + LOADC 1 + STOREI 4 ; store 1 to length field, post-increment addr + LOADC 1 + STOREI 4 ; store 1 to max length field, post-increment addr + SWAP ; swap addr and char value, char is now on ToS + LOADC 255 ; mask lsb of word + AND + BROT ; rotate lsb to msb + BROT + BROT + STOREI ; store it + DROP + RET + +; convert string and index to a byte pointer. +; does a bounds check. +; parameters [ str ptr, char index ] +; returns: byte ptr +_INDEXSTRING: + DEC 1 ; adjust to base 0, string indices start at 1 + OVER ; [ str, index, str ] + LOADI ; [ str, index, length ] + CMPU.S0 GE ; [ str, index, cmp ] + CBRANCH INDEXSTRING_ERR ; [ str, index ] + INC 8 ; account for string header + ADD ; add index to ptr to get byte ptr + RET +INDEXSTRING_ERR: + DROP + DROP + LOADCP _ERRMSG_STRIDX + LOADCP _RUNTIME_ERR + JUMP + +; set a char at a specific index in a string. +; expects a byte pointer and a char value. +; the byte pointer contains the byte address in bits 0-1. +; no bounds check is performed. +; parameters: [ byte ptr, char value ] +_SETSTRINGCHAR: + BPLC.S0 ; [ ptr, rotated char ] + OVER ; [ ptr, rot char, ptr ] + LOADC $FF ;[ptr, rot char, ptr, $FF] + BPLC.S0 ; [ ptr, rot char, ptr, ~mask ] + NOT ; [ ptr, rot char, ptr, mask ] + SWAP ; [ ptr, rot char, mask, ptr ] + LOADI ; [ ptr, rot char, mask, word ] + AND ; [ ptr, rot char, masked word ] + OR ; [ ptr, new word ] + STOREI ; [ ptr ] + DROP + RET + +; convert string to char +; string must have length of 1, otherwise a runtime error occurs +; parameters [ pointer to string ] +; returns: char value +_STRINGTOCHAR: + DUP ; dup addr for later + LOADI ; load string length + LOADC 1 ; compare with 1 + CMPU EQ + CBRANCH STRINGTOCHAR_1 + DROP + LOADCP _ERRMSG_STR2CHAR ; if not 1, issue runtime error + LOADCP _RUNTIME_ERR + JUMP +STRINGTOCHAR_1: + INC 8 ; increment addr to skip string header + LOADI ; load first string word + BROT ; rotate msb byte to lsb + ; which is the first char/byte of the string. + ; since the last string word is always zero-padded, + ; we dont need to mask the byte + RET + +; set the current length of a pascal string. +; must be less or equal than the maximum length of the string. +; if the new length is larger than the old length, the string +; is padded with zero bytes. +; parameters: [ pointer to string, new length ] + .EQU SETSTRL_NEWLEN 0 + .EQU SETSTRL_PTR 4 + .EQU SETSTRL_FS 8 +_SETSTRINGLENGTH: + FPADJ -SETSTRL_FS + DUP + STORE SETSTRL_NEWLEN + SWAP ; [ newlen, ptr ] + DUP ; [ newlen, ptr, ptr ] + STORE SETSTRL_PTR ; [ newlen, ptr ] + INC 4 ; skip to max length field [ newlen, ptr+4 ] + LOADI ; load max length [ newlen, maxlen ] + CMPU.S1.X2Y GE ; new length > max_length? [ newlen, maxlen, cmp_result ] + CBRANCH.Z SETSTRL_0_0 ; if not, skip the following [ newlen, maxlen ] + ; if it is, clamp new length to max length + NIP ; [ maxlen ] + DUP ; [ maxlen, maxlen ] + STORE SETSTRL_NEWLEN ; store maxlen as newlen [ ] + BRANCH SETSTRL_0 +SETSTRL_0_0: + DROP ; remove maxlen +SETSTRL_0: ; newlen is on stack here + LOAD SETSTRL_PTR ; load ptr to string, size field + ; stack is now: [ newlen, ptr ] + ; loop from addr + old_length - 1 + ; to addr + new_length - 1: + ; SETSTRINGCHAR(a, chr(0)) + LOADI ; load current length [ newlen, oldlen ] + CMPU LE ; new length <= old length? + CBRANCH SETSTRL_1 ; if yes, skip padding + + ; string is being expanded, need to pad with zero bytes + LOAD SETSTRL_NEWLEN ; load new length + LOAD SETSTRL_PTR ; load string pointer yet again + LOADI ; load current(old) length + SUB ; calculate length difference (old - new) + ; this is out char counter + LOAD SETSTRL_PTR ; load string pointer yet again + LOADI.S1.X2Y ; load old string length + ADD ; add to pointer + INC 8 ; adjust for string header + +SETSTRL_0_L: + DUP ; duplicate pointer + LOADC 0 ; zero arg + LOADCP _SETSTRINGCHAR + CALL + + INC 1 ; increment pointer + SWAP ; swap pointer and counter + DEC 1 ; decrement counter + DUP + CBRANCH.Z SETSTRL_1_0 ; if counter is zero, end loop + SWAP ; swap pointer and counter again + BRANCH SETSTRL_0_L +SETSTRL_1_0: + DROP + DROP ; remove pointer and counter +SETSTRL_1: ; pad last word of string with zero bytes + LOAD SETSTRL_PTR + INC 8 ; get pointer to first word + LOAD SETSTRL_NEWLEN + ADD ; get pointer to last word + LOADI.S1.X2Y ; load word, keep addr + OVER ; duplicate addr + LOADC 3 + AND ; addr modulo 4 + SHL 2 ; * 4 = offset into table borrowed from COPYSTRING + LOADCP CPSTR_MASK + ADD ; add up to addr of mask + LOADI ; load mask + ; now on stack: [ word ptr, word, word mask ] + AND ; apply mask [ word ptr, word AND mask ] + STOREI ; store new word + DROP ; remove addr from STOREI + +SETSTRL_XT2: + LOAD SETSTRL_PTR ; store new length in the length field + LOAD SETSTRL_NEWLEN ; of the string + STOREI + DROP + + FPADJ SETSTRL_FS + RET + +; check if a char value is contained +; within a string. +; parameters: [ value, ptr to string ] +; returns: nonzero if string contains value, 0 if not +_ISCHARINSTRING: + FPADJ -4 + SWAP + STORE 0 ; store value to find + LOADI.S1.X2Y ; load string length + SWAP ; [ length, ptr ] + INC 8 ; skip string header + SWAP ; [ ptr+8, length ] +ISCHIS_L: + DUP ; check if bytes remaining + CBRANCH.Z ISCHIS_XT0 ; if zero, exit + SWAP ; [ length, ptr+n ] + DUP ; [ length, ptr+n, ptr+n ] + LOADI.S1.X2Y ; [ length, ptr+n, ptr+n, word ] + BSEL ; [ length, ptr+n, char ] + LOAD 0 + CMP EQ ; compare with char value + CBRANCH ISCHIS_FND ; found it + ; [ length, ptr+n ] + INC 1 ; increment byte ptr + SWAP ; [ ptr+n, length ] + DEC 1 ; decrement counter + BRANCH ISCHIS_L +ISCHIS_FND: + LOADC 1 + BRANCH ISCHIS_XT +ISCHIS_XT0: + LOADC 0 +ISCHIS_XT: + NIP ; remove ptr + NIP ; and counter, keeping the result code + FPADJ 4 + RET + +; check if an integer value is contained +; within an array of integers +; parameters: [ value, ptr to array, size in words ] +; returns: 1 if array contains value, 0 if not +_ISINTINARRAY: + FPADJ -4 + SWAP ; swap size and array + STORE 0 ; store ptr +ISINTINA_L: + DUP ; duplicate word counter + CBRANCH.Z ISINTINA_XT0 ; if counter is zero, exit + OVER ; copy value to top of stack + LOAD 0 ; load ptr + INC.S1.X2Y 4 ; increment ptr, keep old value on stack + STORE 0 ; store new ptr + LOADI ; load array element via old ptr + CMP NE ; compare value and array element + CBRANCH ISINTINA_1 ; if not equal, skip the following + DROP + DROP ; drop counter and value + LOADC 1 ; we found our value, load 1 as return value + BRANCH ISINTINA_XT ; and branch to exit +ISINTINA_1: + DEC 1 ; decrease counter + BRANCH ISINTINA_L ; and loop +ISINTINA_XT0: + DROP ; drop counter and value + DROP + LOADC 0 ; return 0 +ISINTINA_XT: + FPADJ 4 + RET + +; Set a bit in a word. The bit is specified by index (0-31) +; where 0 indicates the lsb and 31 the msb. +; parameters: [ word, bit number ] +; returns: word with bit set +_SETBIT: + SHL 2 ; bit number * 4 = offset into table + LOADCP _BITTABLE + ADD + LOADI ; get bit value + OR ; combine original value and shifted bit + RET + +; Clear a bit in a word. The bit is specified by index (0-31) +; where 0 indicates the lsb and 31 the msb. +; parameters: [ word, bit number ] +; returns: word with bit cleared +_CLEARBIT: + SHL 2 ; bit number * 4 = offset into table + LOADCP _BITTABLE + ADD + LOADI ; get bit value + NOT ; invert mask + AND ; combine original value and shifted bit + RET + +; test if a bit is set a word. The bit is specified by index (0-31) +; where 0 indicates the lsb and 31 the msb. +; parameters: [ bit number, word ] +; returns: 1 if bit is set, 0 otherwise +_TESTBIT: + SWAP + SHL 2 ; bit number * 4 = offset into table + LOADCP _BITTABLE + ADD + LOADI ; get bit value + AND ; combine original value and shifted bit + LOADC 0 + CMP NE ; if not zero, return 1 + RET + +; Convert an integer array to a 32-bit set, by +; iterating over all array values and calling SETBIT. +; parameters: [ array ptr, array size in words ] +; returns: set value as a single word +_ARRAYTOSET: + FPADJ -4 ; local var offset 0 is the result value + LOADC 0 + STORE 0 ; clear result value +ARRAYTOSET_L: + DUP ; duplicate word counter + CBRANCH.Z ARRAYTOSET_X ; if zero, we are done + SWAP ; swap counter and ptr, ptr is on ToS + LOADI.S1.X2Y ; load value from array, keep ptr + LOADC 31 + AND ; clamp bit number to 31 + LOAD 0 ; load result value + SWAP ; SETBIT wants [ value, bit number ] + LOADCP _SETBIT ; set the bit + CALL + STORE 0 ; store result + INC 4 ; increment ptr + SWAP ; swap ptr and counter again + DEC 1 ; decrement counter + BRANCH ARRAYTOSET_L ; and loop +ARRAYTOSET_X: + DROP ; remove word counter + DROP ; remove ptr + LOAD 0 ; load result + FPADJ 4 + RET + +_BITTABLE: + .WORD %00000000000000000000000000000001 + .WORD %00000000000000000000000000000010 + .WORD %00000000000000000000000000000100 + .WORD %00000000000000000000000000001000 + .WORD %00000000000000000000000000010000 + .WORD %00000000000000000000000000100000 + .WORD %00000000000000000000000001000000 + .WORD %00000000000000000000000010000000 + .WORD %00000000000000000000000100000000 + .WORD %00000000000000000000001000000000 + .WORD %00000000000000000000010000000000 + .WORD %00000000000000000000100000000000 + .WORD %00000000000000000001000000000000 + .WORD %00000000000000000010000000000000 + .WORD %00000000000000000100000000000000 + .WORD %00000000000000001000000000000000 + .WORD %00000000000000010000000000000000 + .WORD %00000000000000100000000000000000 + .WORD %00000000000001000000000000000000 + .WORD %00000000000010000000000000000000 + .WORD %00000000000100000000000000000000 + .WORD %00000000001000000000000000000000 + .WORD %00000000010000000000000000000000 + .WORD %00000000100000000000000000000000 + .WORD %00000001000000000000000000000000 + .WORD %00000010000000000000000000000000 + .WORD %00000100000000000000000000000000 + .WORD %00001000000000000000000000000000 + .WORD %00010000000000000000000000000000 + .WORD %00100000000000000000000000000000 + .WORD %01000000000000000000000000000000 + .WORD %10000000000000000000000000000000 + + .CPOOL + + .EQU _HEAP_HDR_SZ 8 + .EQU _HEAP_MIN_SZ 32 +; MEM_ALLOC +; allocate a chunk of memory +; parameters: [ size in bytes ] +; returns: starting address of allocated memory, or 0 if +; no more space is available + .EQU MA_REQD_SIZE 0 + .EQU MA_CURCHUNK 4 + .EQU MA_LASTCHUNK 8 + .EQU MA_CURCHUNK_SIZE 12 + .EQU MA_NEWCHUNK 16 + .EQU MA_FS 20 +_MEM_ALLOC: + FPADJ -MA_FS + ; round up requested size + LOADC _HEAP_HDR_SZ + ADD + LOADC _HEAP_MIN_SZ -1 + ADD + LOADC ~_HEAP_MIN_SZ + 1 + AND + STORE MA_REQD_SIZE + + ;LOAD MA_REQD_SIZE + ;LOADCP PRINTDEC + ;CALL + ;LOADCP NEWLINE + ;CALL + + ; get current alloc pointer (points to last previously seen free chunk) + LOADCP _HEAP_CUR + LOADI + STORE MA_CURCHUNK +MEM_ALLOC_L0: + ; get next free chunk + LOAD MA_CURCHUNK + DUP + STORE MA_LASTCHUNK ; last chunk = cur chunk + LOADI ; load next ptr + DUP ; dup ptr for accessing the size + STORE MA_CURCHUNK ; cur chunk = cur chunk^.next + INC 4 ; skip to size field + LOADI ; load it + STORE MA_CURCHUNK_SIZE ; and store to local var + + ;LOADC ':' + ;LOADCP CONOUT + ;CALL + + ;LOAD MA_CURCHUNK + ;LOADCP PRINTHEXW + ;CALL + + ;LOADCP 's' + ;LOADCP CONOUT + ;CALL + + ;LOAD MA_CURCHUNK_SIZE + ;LOADCP PRINTHEXW + ;CALL + + ;LOADCP '?' + ;LOADCP CONOUT + ;CALL + + ;LOAD MA_REQD_SIZE + ;LOADCP PRINTHEXW + ;CALL + + ;LOADCP NEWLINE + ;CALL + + ; if requested size is less or equal than chunk size, jump to allocation + LOAD MA_REQD_SIZE + LOAD MA_CURCHUNK_SIZE + CMPU LE + CBRANCH MEM_ALLOC_A + ; if back to where we started, return failure + LOADCP _HEAP_CUR + LOADI + LOAD MA_CURCHUNK + CMPU NE + CBRANCH MEM_ALLOC_L0 ; else, go to next chunk + + ;LOADC 'e' + ;LOADCP CONOUT + ;CALL + + ; TODO: grow heap and add new chunk, check for + ; collision with downward growing user stack (FP) + + LOADC 0 + BRANCH MEM_ALLOC_XT + + ; allocation: +MEM_ALLOC_A: + LOAD MA_CURCHUNK + STORE MA_NEWCHUNK + + LOADCP _HEAP_CUR ; remember last chunk + LOAD MA_LASTCHUNK ; for next invocation + STOREI + DROP + ; split chunk: + ; skip if requested_size = chunk size + LOAD MA_CURCHUNK_SIZE + LOAD MA_REQD_SIZE + CMPU EQ + CBRANCH MEM_ALLOC_A0 + ; new chunk is head portion of current chunk + ; new chunk size = requested size + LOAD MA_NEWCHUNK + INC 4 ; skip zo size field + LOAD MA_REQD_SIZE + STOREI ; store size + DROP + + ;LOADC '|' + ;LOADCP CONOUT + ;CALL + + ; current chunk is the split off free chunk + ; current chunk start += requested size + ; current chunk size -= requested size + LOAD MA_CURCHUNK_SIZE + LOAD MA_REQD_SIZE + SUB ; new size = old size - requested + LOAD MA_CURCHUNK + LOADI ; load old next ptr + + LOAD MA_CURCHUNK + LOAD MA_REQD_SIZE + ADD ; new addr of current chunk = old addr + requested size + DUP + STORE MA_CURCHUNK + ; the stack at this point: [ new size, old next ptr, cur chunk addr ] + ; now write new header + SWAP ; swap next ptr and addr + STOREI 4 ; store next ptr to addr, leave addr + 4 + SWAP ; swap addr and size + STOREI ; store size + DROP + + ; previous chunk next pointer = current chunk pointer + LOAD MA_LASTCHUNK + LOAD MA_CURCHUNK + STOREI + DROP + BRANCH MEM_ALLOC_A1 + +MEM_ALLOC_A0: + ;LOADC 'O' + ;LOADCP CONOUT + ;CALL + + ; if chunk was not split: previous chunk next ptr = current chunk next ptr + LOAD MA_LASTCHUNK + LOAD MA_CURCHUNK + LOADI + STOREI + DROP + +MEM_ALLOC_A1: + ; return new chunk pointer + header size + LOAD MA_NEWCHUNK + INC _HEAP_HDR_SZ + +MEM_ALLOC_XT: + FPADJ MA_FS + RET + +; MEM_FREE +; free a chunk of memory which was allocated by MEM_ALLOC +; parameters: [ address previously returned by MEM_ALLOC ] + .EQU MF_FREECHUNK 0 + .EQU MF_CURCHUNK 4 + .EQU MF_NEXTCHUNK 8 + .EQU MF_CURCHUNK_END 12 + .EQU MF_FS 16 +_MEM_FREE: + FPADJ -MF_FS + DEC _HEAP_HDR_SZ + DUP ; dup for comparison below [ ptr, ptr ] + DUP ; dup for other comparison below [ ptr, ptr, ptr ] + STORE MF_FREECHUNK ; to-be-freed chunk pointer = address - header size [ptr, ptr ] + LOADCP _HEAP_ANCHOR ; [ ptr, ptr, anchor ] + CMP GT ; [ ptr , cmp ] + CBRANCH MEM_FREE_L ; [ ptr ] + + DUP + LOADCP PRINTHEXW + CALL + + DROP + + LOADCP _ERRMSG_MEMFREE + LOADCP _RUNTIME_ERR + JUMP +MEM_FREE_L: + LOADCP _HEAP_CUR + LOADI ; load current heap pointer + DUP ; dup for comparison below + STORE MF_CURCHUNK + ; on the stack now: [ freechunk, heap_cur ] + CMPU GE + CBRANCH MEM_FREE_L0 + LOADCP _HEAP_ANCHOR + STORE MF_CURCHUNK +MEM_FREE_L0: + ; get current alloc pointer (points to last seen free chunk) + LOAD MF_CURCHUNK + DUP + DUP + INC 4 ; skip curchunk ptr to size field + LOADI ; load size + ADD ; add to curchunk ptr to get end of chunk + STORE MF_CURCHUNK_END + LOADI ; get next chunk pointer + STORE MF_NEXTCHUNK + + ;LOADC 'N' + ;LOADCP CONOUT + ;CALL + ;LOAD MF_NEXTCHUNK + ;LOADCP PRINTHEXW + ;CALL + ;LOADC 'C' + ;LOADCP CONOUT + ;CALL + ;LOAD MF_CURCHUNK + ;LOADCP PRINTHEXW + ;CALL + ;LOADC 'F' + ;LOADCP CONOUT + ;CALL + ;LOAD MF_FREECHUNK + ;LOADCP PRINTHEXW + ;CALL + ;LOADCP NEWLINE + ;CALL + + ; if next ptr < to-be-freed, skip to next chunk + LOAD MF_NEXTCHUNK + LOAD MF_FREECHUNK + CMPU LT + CBRANCH MEM_FREE_CT1 + +MEM_FREE_INS: + LOAD MF_FREECHUNK + LOAD MF_NEXTCHUNK + CMP NE + CBRANCH MEM_FREE_INS1 + + LOADCP _ERRMSG_MEMDFREE + LOADCP _RUNTIME_ERR + JUMP + +MEM_FREE_INS1: + + ; to-be-freed chunk next ptr = next chunk + LOAD MF_FREECHUNK + LOAD MF_NEXTCHUNK + STOREI + DROP + + ; current chunk next ptr = to-be-freed chunk + LOAD MF_CURCHUNK + LOAD MF_FREECHUNK + STOREI + DROP + + ;LOADC 'i' + ;LOADCP CONOUT + ;CALL + + ; merge down if needed + ; if current chunk end = to-be-freed chunk start: + ; current chunk size += to-be-freed size + ; to-be-freed chunk = current chunk + ; current chunk next = next + LOAD MF_CURCHUNK_END + LOAD MF_FREECHUNK + CMPU NE + CBRANCH MEM_FREE_CT + + ;LOADC 'v' + ;LOADCP CONOUT + ;CALL + + LOAD MF_CURCHUNK + INC 4 + DUP ; dup addr of cur chunk size for STOREI below + LOADI ; get cur chunk size + LOAD MF_FREECHUNK + INC 4 + LOADI ; get to-be-freed chunk size + ADD + STOREI ; store new cur chunk size + DROP + + LOAD MF_CURCHUNK ; set current chunk next pointer again + LOAD MF_NEXTCHUNK + STOREI ; store and reuse addr + STORE MF_FREECHUNK ; to-be-freed chunk becomes current chunk + + ; merge up if needed + ; if to-be-freed chunk end = next chunk start: + ; to-be-freed-chunk size += next chunk size + ; to-be-freed next ptr = next chunk next ptr +MEM_FREE_CT: + LOAD MF_FREECHUNK + DUP + INC 4 + LOADI + ADD ; calculate to-be-freed chunk end + LOAD MF_NEXTCHUNK + CMPU NE + CBRANCH MEM_FREE_CT0 + + ;LOADC '^' + ;LOADCP CONOUT + ;CALL + + LOAD MF_FREECHUNK ; store next chunk next ptr to to-be-freed next ptr + LOAD MF_NEXTCHUNK + LOADI + STOREI 4 ; store and post-increment addr to to-be-freed size field + LOADI.S1.X2Y ; load size and keep addr + LOAD MF_NEXTCHUNK + INC 4 + LOADI ; get next chunk size + ADD + STOREI + DROP + +MEM_FREE_CT0: + + BRANCH MEM_FREE_XT + +MEM_FREE_CT1: + ;LOADC '>' + ;LOADCP CONOUT + ;CALL + ; if we are at the end of the list, insert there + LOADCP _HEAP_ANCHOR + LOAD MF_NEXTCHUNK + CMPU EQ + CBRANCH MEM_FREE_INS + + ; move to next chunk + LOAD MF_NEXTCHUNK + STORE MF_CURCHUNK + BRANCH MEM_FREE_L0 + +MEM_FREE_XT: + ; reset current heap pointer because + ; a merge might have invalidated it + LOADCP _HEAP_CUR + LOADCP _HEAP_ANCHOR + STOREI + DROP + + FPADJ MF_FS + RET + +; MEM_INIT +; Initialize dynamic memory, user stack and return stack. +; Since the return stack is no longer valid afterwards, directly +; jumps to _MAIN instead of using RET. + +; parameters: [ start of heap address ] +_MEM_INIT: + ; initialize anchor chunk with start of heap address + ; and heap size - header size + LOADCP _HEAP_CUR ; load addr of _HEAP_CUR for STOREI below + LOADCP _HEAP_ANCHOR + DUP + DUP ; anchor points to itself at first + STOREI 4 + LOADC 0 ; store size 0 + STOREI + DROP + STOREI ; store _HEAP_ANCHOR to _HEAP_CUR + DROP + + LOADCP _HEAP_SZ_PTR ; load the value of the heap size from + LOADI ; the program header + + ; set user stack pointer to heap start + heap size + stack size + OVER ; [ start, size, start ] + OVER ; [ start, size, start, size ] + ADD ; [ start, size, start+size ] + LOADCP _STACK_SZ_PTR + LOADI + ADD ; add user stack size to get new FP value [ start, size, start+heapsize+stacksize] + STOREREG FP + + LOADREG FP + INC 4 + STOREREG RP ; set RP to start right after user stack + ; this trashes the previous return stack, + ; so we cannot use RET at the end of MEM_INIT + + ; set chunk header + OVER ; [ start, size, start ] + LOADC 0 ; [ start, size, start, 0 ] ; set next chunk ptr + STOREI 4 ; [ start, size , start + 4 ] ; to zero or we get an error in _MEM_FREE + SWAP ; [ start, start + 4, size ] + STOREI ; store the size + DROP ; [ start ] + + LOADC _HEAP_HDR_SZ + ADD ; adjust chunk address for header + + LOADCP _MEM_FREE ; add chunk to free list + CALL + + LOADCP _MAIN + JUMP + +; allocate a string with MEM_ALLOC. +; the string is also initialized. +; parameters: [ max length ] +; returns: pointer to allocated string, or zero if +; no heap space available + +_STRING_ALLOC: + DUP ; [ length, length ] + INC 8 ; adjust length for string header + LOADCP _MEM_ALLOC + CALL ; [ length, addr ] + DUP ; [ length, addr, addr ] + CBRANCH.Z STRING_ALLOC_E ; [ length, addr ] + SWAP ; [ addr, length ] + OVER ; [ addr, length, addr ] + LOADCP _INITSTRINGF ; set max string length (forced) + CALL ; [ addr ] + RET +STRING_ALLOC_E: + SWAP + DROP + RET + + .CPOOL + +LENGTH: + LOADI + RET + +MAXLENGTH: + INC 4 + LOADI + RET + +; issue a runtime error if pointer is zero +_CHECK_ALLOC: + ;TODO: check for heap overrun by user stack + + ;DUP + ;LOADCP _CHECK_CHUNK ; check for corrupted free list + ;CALL + + DUP + CBRANCH.NZ _CHECK_ALLOC_OK + LOADCP _ERRMSG_MEMALLOC + LOADCP _RUNTIME_ERR + JUMP +_CHECK_ALLOC_OK: + RET + +; print the free list for debugging +MEM_DUMP: + LOADC 35 + LOADCP CONOUT + CALL + LOADCP _HEAP_ANCHOR + DUP + LOADCP PRINTHEXW + CALL + LOADC '^' + LOADCP CONOUT + CALL + LOADCP _HEAP_CUR + LOADI + LOADCP PRINTHEXW + CALL + LOADCP NEWLINE + CALL +MEM_DUMP_L0: + DUP ; dup cur ptr for later + DUP ; dup cur ptr for printing + LOADCP PRINTHEXW + CALL + LOADC ' ' + LOADCP CONOUT + CALL + INC 4 + LOADI + LOADCP PRINTHEXW + CALL + LOADC '>' + LOADCP CONOUT + CALL + LOADI ; load next ptr + DUP + LOADCP PRINTHEXW + CALL + LOADCP NEWLINE + CALL + DUP ; dup for comparison + LOADCP _HEAP_ANCHOR + CMPU NE ; if next ptr is anchor, we are done + CBRANCH MEM_DUMP_L0 + DROP + RET + +; check if a pointer is part of the free list +; args: pointer returned by MEM_ALLOC +; throws runtime error if the pointer is found +_CHECK_CHUNK: + FPADJ -4 + LOADC _HEAP_HDR_SZ ; adjust for header + SUB + STORE 0 ; store chunk addr in local var + + LOADCP _HEAP_ANCHOR ; start loop with anchor address +CHK_CH_L: + DUP ; current chunk addr is on stack + LOADI ; load next ptr + LOAD 0 ; load addr to be checked + CMP EQ ; if equal, error + CBRANCH.NZ CHK_ERR + + LOADI ; load next ptr again + LOADCP _HEAP_ANCHOR + CMP.S0 EQ ; compare with anchor, keep ptr on stack + CBRANCH.Z CHK_CH_L ; in not equal, loop + + DROP ; remove current chunk ptr + + FPADJ 4 + RET +CHK_ERR: + LOAD 0 + LOADCP PRINTHEXW + CALL + LOADCP NEWLINE + CALL + + LOADCP MEM_DUMP + CALL + ; remove one return stack entry + ; for reporting the correct PC + ; since _CHECK_CHUNK is + ; always called by another checking + ; routine (e.g. _CHECK_ALLOC) + LOADREG RP + DEC 4 + STOREREG RP + + LOADCP _ERRMSG_MEMBROKEN + LOADCP _RUNTIME_ERR + JUMP + +; array bounds check +; parameters [ index, array size ] +; throws a runtime error when not inside bounds +_BOUNDSCHECK: + CMPU LT + CBRANCH _BOUNDSCHECK_OK + LOADCP _ERRMSG_ARRAY_OOB + LOADCP _RUNTIME_ERR + JUMP +_BOUNDSCHECK_OK: + RET + +; subrange check +; parameters: [ value, min, max ] +; throws runtime error when not inside bounds +_RANGECHECK: + FPADJ -4 + STORE 0 ; store max value + OVER ; dup value, stack is now [ v, min, v ] + CMP GT ; if min is greater than value + CBRANCH _RANGE_ERR ; then it is a runtime error + LOAD 0 ; load max again, stack is now [ v, max ] + CMP GT ; if value is greater than max + CBRANCH _RANGE_ERR ; then it is a runtime error + FPADJ 4 + RET +_RANGE_ERR: + LOADCP _ERRMSG_RANGE + LOADCP _RUNTIME_ERR + JUMP + +; enum range check +; parameters: [ value, max ] +; throws runtime error when outside bounds +_ENUMCHECK: + CMPU GT + CBRANCH _ENUM_ERR + RET +_ENUM_ERR: + LOADCP _ERRMSG_ENUM + LOADCP _RUNTIME_ERR + JUMP + +HALT: + LOADCP PTERM + JUMP + +; Show runtime error, to be called from Pascal. +; The string must end in a null byte, for example +; by having a greater maximum string length than +; actual length, or by adding a chr(0) at the end. +; parameters: [ ptr to pascal string ] +RUNTIMEERROR: + INC 8 ; skip string header + ; fall through to _RUNTIME_ERR + +; show runtime error message and abort program +; args: error message +_RUNTIME_ERR: + LOADCP _ERRMSG_1 + LOADCP PRINTLINE + CALL + LOADREG RP + LOADI + LOADCP PRINTHEXW + CALL + LOADCP NEWLINE + CALL + LOADCP PRINTLINE + CALL + LOADCP NEWLINE + CALL + + LOADCP PTERM + JUMP + + .EQU _ESP_EMPTY 0 + +_CLEARESTACK: + LOADREG ESP + LOADC _ESP_EMPTY + CMP EQ + CBRANCH _CLEARESTACK_XT + DROP + BRANCH _CLEARESTACK +_CLEARESTACK_XT: + RET + +; Terminate program: clear estack and +; jump to coreloader +PTERM: + LOADCP _CLEARESTACK + CALL + LOADCP LOADER_START + JUMP + +; Return an integer representation +; of a real(float32) number. +; This is our native format, so +; we do not have to do anything. +ENCODEFLOAT32: + RET + + .CPOOL + +_HEAP_START: .WORD 0 +_HEAP_MAX: .WORD 0 +_HEAP_CUR: .WORD 0 +_HEAD_FIRSTF: .WORD 0 +_HEAP_ANCHOR: .WORD 0,0 + +_ERRMSG_1: .BYTE 13,10,"Runtime error at PC ",0 +_ERRMSG_ARRAY_OOB: .BYTE "Array index out of bounds",0 +_ERRMSG_CONSTWR: .BYTE "Write to constant string",0 +_ERRMSG_STR2CHAR: .BYTE "Invalid conversion from string to char",0 +_ERRMSG_STRIDX: .BYTE "String index out of bounds",0 +_ERRMSG_RANGE: .BYTE "Range check",0 +_ERRMSG_ENUM: .BYTE "Invalid enum value",0 +_ERRMSG_MEMFREE: .BYTE "Invalid pointer in dispose",0 +_ERRMSG_MEMDFREE: .BYTE "Chunk already disposed",0 +_ERRMSG_MEMALLOC: .BYTE "Out of heap space",0 +_ERRMSG_MEMBROKEN: .BYTE "Heap corrupted",0 +NEWLINESTR: + .WORD 2,0 + .BYTE 13,10 + + .CPOOL diff --git a/lib/sdcardboot.s b/lib/sdcardboot.s new file mode 100644 index 0000000..f3b7c9c --- /dev/null +++ b/lib/sdcardboot.s @@ -0,0 +1,613 @@ + .EQU SPIREG $880 + + .EQU SPI_CTRL_WRITE %100000000000000 + .EQU SPI_RX_FILTER_EN %010000000000000 + .EQU SPI_TXRX_EN %001000000000000 + .EQU SPI_CLK_F_EN %000100000000000 + .EQU SPI_CLK_DIV_WR %000010000000000 + .EQU SPI_RX_RD %000001000000000 + .EQU SPI_TX_WR %000000100000000 + + .EQU SPI_C_D %100000000000000 + .EQU SPI_C_CHG %010000000000000 + .EQU SPDI_C_BUSY %001000000000000 + .EQU SPI_TX_RDY %000100000000000 + .EQU SPI_TX_EMPTY %000010000000000 + .EQU SPI_RX_AVAIL %000001000000000 + .EQU SPI_RX_OVR %000000100000000 + + .EQU SPI_TXRX_EN_MASK ~SPI_TXRX_EN + +_WAIT: + LOADC 10 +_WAITL: + LOADC WAIT1MSEC + CALL + DEC 1 + DUP + CBRANCH.NZ _WAITL + DROP + RET + +INITSDCARD: + LOADC WAIT1MSEC + CALL + + LOADC _SPIINIT1 + CALL + + ;LOADC 'I' + ;LOADCP CONOUT + ;CALL + + LOADC _WAITSPITXRDY + CALL + + ;LOADC 'W' + ;LOADCP CONOUT + ;CALL + + ; send RESET CARD command + LOADC $95 ; send cmd0 with arg 0 and checksum $95 + LOADC $0 + LOADC $0 + LOADC SENDCMD_R1 + CALL + + DROP ; TODO: handle errors + ;LOADCP PRINTHEXW ; print status returned by the card + ;CALL + ;LOADCP NEWLINE + ;CALL + + ;LOADC '9' + ;LOADCP CONOUT + ;CALL + + LOADC _WAITSPITXRDY + CALL + + LOADC _WAIT + CALL + + ;LOADC '1' + ;LOADCP CONOUT + ;CALL + + LOADC $87 + LOADC $01AA + LOADC $8 + LOADC SENDCMD_R7 + CALL + + DROP + + LOADC _WAITSPITXRDY + CALL + + ;LOADC '2' + ;LOADCP CONOUT + ;CALL + + ;LOADCP _WAIT + ;CALL + + ;LOADC '.' + ;LOADCP CONOUT + ;CALL + + LOADC CARDINITV2 + CALL + + ;LOADC '+' + ;LOADCP CONOUT + ;CALL + + + LOADC CARDFASTCLK + CALL + + ;LOADC '3' + ;LOADCP CONOUT + ;CALL + + ; CMD16: set block size to 512 byte + LOADC 0 + LOADC 512 + LOADC 16 + LOADCP SENDCMD_R1 + CALL + + DROP + + ;LOADCP _WAIT + ;CALL + + ;LOADC '4' + ;LOADCP CONOUT + ;CALL + + RET + +; read a 512-byte-block from the card +; args: block number +; returns: 0 on success +CARDREADBLK: + LOADC 128 ; number of words in a block + SWAP ; move block number up the stack + LOADCP CARD_BUF + SWAP + LOADC 0 + SWAP + LOADC 17 ; CMD17: read block + LOADC SENDCMD_PKT + CALL + RET + +; send the card initialization command +; wait until the card responds +CARDINITV2: + LOADC 100 ; try up to 100 times +CARD_LOOP1: + LOADC 50 ; wait 50 msec +CARD_LOOP2: + LOADC WAIT1MSEC + CALL + DEC 1 + DUP + CBRANCH.NZ CARD_LOOP2 + DROP ; remove loop count value + + LOADC $0 + LOADC $0 + LOADC 58 + LOADC SENDCMD_R7 ; send CMD58 + CALL + DROP ; ignore result (why?) + + LOADC $0 + LOADCP $40000000 + LOADC 41 + LOADC SENDACMD_R1 ; send ACMD41 + CALL + + CBRANCH.Z CARD_OK ; if result is zero, the command succeded + ; and the card initialization is finished + DEC 1 + DUP + CBRANCH.NZ CARD_LOOP1 + DROP ; remove outer loop count value + + RET +CARD_OK: + DROP ; remove outer loop count value + + ; CMD16: set block size to 512 byte + LOADC 0 + LOADC 512 + LOADC 16 + LOADC SENDCMD_R1 + CALL + DROP ; ignore return value + + RET + +; set fast transfer rate +CARDFASTCLK: + LOADC SPIREG + ; set clock divider to ~2,6MHz + LOADC SPI_CLK_DIV_WR+10 + STOREI + DROP + RET + +; perform first phase of card initialization +; which is to enable clock and wait a bit +; leaves the clock running +_SPIINIT1: + LOADC SPIREG + ; set clock divider to ~325KHz + LOADC SPI_CLK_DIV_WR+64 + STOREI + DROP + + ; clear all flags + enable clock + ; /CS and MOSI are default high + LOADC SPIREG + LOADCP SPI_CTRL_WRITE,SPI_CLK_F_EN + STOREI + DROP + + ; we should wait at least for 74 clock cycles now + LOADC 2 ; wait 2 msec, that should be ~300 cycles +_SPIINIT1L: + LOADC WAIT1MSEC + CALL + DEC 1 + DUP + CBRANCH.NZ _SPIINIT1L + DROP + + LOADC SPIREG + LOADCP SPI_CTRL_WRITE ; disable clock + STOREI + DROP + + LOADCP WAIT1MSEC + CALL + + RET + +; wait for transmission to finish +; (wait for TX_EMPTY bit) +_SPIWAITTX: + LOADC SPIREG + LOADI + LOADCP SPI_TX_EMPTY + AND + CBRANCH.Z _SPIWAITTX + RET + +; finalize a command that has been sent: +; wait until the transmitter is idle +; then disable clock and set MOSI high +_SPIENDCMD: + LOADC $FF + LOADC _SENDBYTE + CALL + LOADC $FF + LOADC _SENDBYTE + CALL + + ;LOADC 'E' + ;LOADCP CONOUT + ;CALL + + LOADC _SPIWAITTX + CALL + + ;LOADC 'w' + ;LOADCP CONOUT + ;CALL + LOADC _WAIT_S ; wait a short time + CALL + + LOADC SPIREG + LOADCP SPI_IDLE_FLAGS ; turn off transceiver + LOADI + STOREI + DROP + + ; wait for a few instructions + LOADC 100 +SPIEND_LP: DEC 1 + DUP + CBRANCH.NZ SPIEND_LP + DROP + + RET + +_WAIT_S: + LOADC 100 +_WAIT_S_L: + DEC 1 + DUP + CBRANCH.NZ _WAIT_S_L + DROP + RET + +; clear RX fifo +CLEAR_RX_FIFO: +CLEAR_RX_L1: + LOADC SPIREG + LOADI + + ;DUP + ;LOADCP PRINTHEXW + ;CALL + ;LOADCP NEWLINE + ;CALL + + LOADC SPI_RX_AVAIL + AND + CBRANCH.Z CLEAR_RX_X + LOADC SPIREG + LOADC SPI_RX_RD + STOREI + DROP + + ; FIXME: it seems that this + ; does not remove a byte from the fifo, + ; rx_avail stays on, but only after the first + ; byte has been received and read + + ;LOADC 'x' + ;LOADCP CONOUT + ;CALL + + BRANCH CLEAR_RX_L1 +CLEAR_RX_X: + RET + +_WAITSPITXRDY: + LOADC SPIREG + LOADI + LOADCP SPI_TX_RDY + AND + CBRANCH.Z _WAITSPITXRDY + RET + +; send a command and receive a data packet response +; args: packet size in words, buffer pointer +; checksum byte, 32-bit cmd arg, cmd number +; returns: 0 on success +SENDCMD_PKT: + ; first send the command + LOADC SENDCMD_0 + CALL + + LOADC _RCVBYTE ; receive R1 response + CALL + + CBRANCH.NZ SENDCMD_PKT_E ; on success we get 0 + + ; now wait for data token +SENDCMD_PKT_L: + LOADC _RCVBYTE + CALL + LOADC $FF + CMP EQ + CBRANCH SENDCMD_PKT_L + + ; parameters for _RCVWORDS are on the stack now + LOADC _RCVWORDS + CALL + + ; receive 2 crc bytes + LOADC _RCVBYTE + CALL + BROT + LOADC _RCVBYTE + CALL + OR + + ; terminate command + LOADC _SPIENDCMD + CALL + + DROP ; we ignore the checksum for now + + LOADC 0 + RET +SENDCMD_PKT_E: + DROP ; remove remaining args + DROP + LOADC -1 ; return code for error + RET + +; send a command and receive a 1-byte-response (R1) +; args: checksum byte, 32-bit cmd arg, cmd number +; returns: received byte +SENDCMD_R1: + LOADC SENDCMD_0 + CALL + + LOADC _RCVBYTE + CALL + + ;LOADC 'R' + ;LOADCP CONOUT + ;CALL + + ;terminate command (/cs high, disable clock) + LOADC _SPIENDCMD + CALL + + RET + +; send a command +; args: checksum byte, 32-bit cmd arg, cmd number +SENDCMD_0: + ; clear RX FIFO first + LOADC CLEAR_RX_FIFO + CALL + + ;LOADC '>' + ;LOADCP CONOUT + ;CALL + + ; cmd byte is at TOS at this point + LOADC $40 ; or in start of frame bit + OR + LOADC _SENDBYTE + CALL + ; cmd arg is at TOS now + LOADC _SENDWORD + CALL + ; checksum byte is at TOS now + LOADC _SENDBYTE + CALL + + LOADC _XCVR_ENABLE ; enable transceiver last, + CALL ; a complete command should + RET ; fit into the tx fifo + +; send ACMD and receive a 1-byte-response (R1) +; args: checksum byte, 32-bit cmd arg, ACMD number +; returns: received byte or -1 if first response byte +; indicated an error +SENDACMD_R1: + LOADC $0 + LOADC $0 + LOADC 55 ; send CMD55 + LOADC SENDCMD_R1 + CALL + + LOADC 1 ; 1 = idle state, no errors + CMP NE + CBRANCH.NZ SENDACMD_ERR + + ; pass our args to SENDCMD_R1 + LOADC SENDCMD_R1 + CALL + RET + +SENDACMD_ERR: + LOADCP -1 + RET + +; send a command and receive a 4+1-byte-response (R7) +; args: checksum byte, 32-bit cmd arg, cmd number +; returns: received word or -1 if first response byte +; indicated an error + +SENDCMD_R7: + ; send the command + LOADC SENDCMD_0 + CALL + + ;LOADC '7' + ;LOADCP CONOUT + ;CALL + + LOADC _RCVBYTE + CALL + + LOADC _RCVWORD + CALL + + ;terminate command (/cs high, disable clock) + LOADC _SPIENDCMD + CALL + + SWAP ; swap 1st response byte with received word + LOADC %011111110 ; check for any error flags + AND + CBRANCH.Z SENDCMD_R7_NOERR + DROP + LOADC -1 +SENDCMD_R7_NOERR: + RET + +; send a word as 4 bytes, msb first +_SENDWORD: + DUP ; remember original value for later + + BROT ; rotate msb to lsb (byte 0) + LOADC 255 + AND.S0 ; isolate byte, keep previous value + LOADC _SENDBYTE + CALL + + BROT ; byte 1 + LOADC 255 + AND.S0 + LOADC _SENDBYTE + CALL + + BROT ; byte 2 + LOADC 255 + AND + LOADC _SENDBYTE + CALL + + ; byte 3 is already on the stack + LOADC 255 + AND + LOADC _SENDBYTE + CALL + + RET + +; receive multiple 4-byte-words and store into +; memory buffer +; args: number of words, pointer to buffer +_RCVWORDS: + FPADJ -4 + STORE 0 ; store pointer arg into local variable + ; keep counter on stack +_RCVWORDS_LP: + LOAD 0 ; load buf pointer for STOREI + LOADC _RCVWORD + CALL ; receive a word + STOREI 4 ; store to buf with postincrement + STORE 0 ; store pointer variable + + DEC 1 ; decrement word counter + DUP + CBRANCH.NZ _RCVWORDS_LP ; if not null, loop + DROP ; remove counter value + + FPADJ 4 + RET + +; receive 4 bytes, return as word +_RCVWORD: + LOADC _RCVBYTE ; receive first byte + CALL + BROT ; rotate byte to left + + LOADC _RCVBYTE ; receive second byte + CALL + OR ; or first and second byte together + BROT ; rotate 1st + 2nd to left + + LOADC _RCVBYTE ; receive third byte + CALL + OR + BROT + + LOADCP _RCVBYTE ; receive fourth byte + CALL + OR + RET + +_XCVR_ENABLE: + LOADC SPIREG + LOADC SPI_TX_FLAGS + LOADI + STOREI + DROP + RET + +; send a byte +; args: byte to be sent +_SENDBYTE: + LOADC SPIREG + LOADI ; load spi io register + LOADCP SPI_TX_RDY + AND ; check tx_rdy bit + CBRANCH.Z _SENDBYTE ; if not set, loop + + LOADC SPI_TX_WR ; TX_WR bit + OR ; OR in byte to be send + + LOADC SPIREG + SWAP ; swap value and addr for STOREI + STOREI ; store word (flags + data) to io register + DROP ; remove STOREI result + + RET + +; receive a byte. receiver must be enabled. +; returns: received byte +_RCVBYTE: + LOADC SPIREG + LOADI ; load spi io register + LOADC SPI_RX_AVAIL + AND.S0 ; check rx_avail bit, keep original value + CBRANCH.NZ RECVGOTIT + DROP ; rx_avail not set, remove register value and loop + BRANCH _RCVBYTE +RECVGOTIT: + LOADC SPIREG + LOADC SPI_RX_RD ; remove one byte from rx fifo + STOREI + DROP + + LOADC 255 + AND ; keep bits 7-0 + RET + +SPI_TX_FLAGS: .WORD SPI_CTRL_WRITE + SPI_TXRX_EN + SPI_RX_FILTER_EN +SPI_IDLE_FLAGS: .WORD SPI_CTRL_WRITE diff --git a/lib/sdcardlib.s b/lib/sdcardlib.s new file mode 100644 index 0000000..9b45e05 --- /dev/null +++ b/lib/sdcardlib.s @@ -0,0 +1,795 @@ +; Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details + .EQU SPIREG $880 + + .EQU SPI_CTRL_WRITE %100000000000000 + .EQU SPI_RX_FILTER_EN %010000000000000 + .EQU SPI_TXRX_EN %001000000000000 + .EQU SPI_CLK_F_EN %000100000000000 + .EQU SPI_CLK_DIV_WR %000010000000000 + .EQU SPI_RX_RD %000001000000000 + .EQU SPI_TX_WR %000000100000000 + + .EQU SPI_C_D %100000000000000 + .EQU SPI_C_CHG %010000000000000 + .EQU SPDI_C_BUSY %001000000000000 + .EQU SPI_TX_RDY %000100000000000 + .EQU SPI_TX_EMPTY %000010000000000 + .EQU SPI_RX_AVAIL %000001000000000 + .EQU SPI_RX_OVR %000000100000000 + + .EQU SPI_TXRX_EN_MASK ~SPI_TXRX_EN + +_WAIT: + LOADC 10 +_WAITL: + LOADCP WAIT1MSEC + CALL + DEC 1 + DUP + CBRANCH.NZ _WAITL + DROP + RET + +INITSDCARD: + LOADCP WAIT1MSEC + CALL + + LOADCP _SPIINIT1 + CALL + + ;LOADC 'I' + ;LOADCP CONOUT + ;CALL + + LOADCP _WAITSPITXRDY + CALL + + ;LOADC 'W' + ;LOADCP CONOUT + ;CALL + + ; send RESET CARD command + LOADC $95 ; send cmd0 with arg 0 and checksum $95 + LOADC $0 + LOADC $0 + LOADCP SENDCMD_R1 + CALL + + DROP ; TODO: handle errors + ;LOADCP PRINTHEXW ; print status returned by the card + ;CALL + ;LOADCP NEWLINE + ;CALL + + ;LOADC '9' + ;LOADCP CONOUT + ;CALL + + LOADCP _WAITSPITXRDY + CALL + + LOADCP _WAIT + CALL + + ;LOADC '1' + ;LOADCP CONOUT + ;CALL + + LOADC $87 + LOADC $01AA + LOADC $8 + LOADCP SENDCMD_R7 + CALL + + DROP + + LOADCP _WAITSPITXRDY + CALL + + ;LOADC '2' + ;LOADCP CONOUT + ;CALL + + ;LOADCP _WAIT + ;CALL + + ;LOADC '.' + ;LOADCP CONOUT + ;CALL + + LOADCP CARDINITV2 + CALL + + ;LOADC '+' + ;LOADCP CONOUT + ;CALL + + + LOADCP CARDFASTCLK + CALL + + ;LOADC '3' + ;LOADCP CONOUT + ;CALL + + ; CMD16: set block size to 512 byte + LOADC 0 + LOADC 512 + LOADC 16 + LOADCP SENDCMD_R1 + CALL + + DROP + + ;LOADCP _WAIT + ;CALL + + ;LOADC '4' + ;LOADCP CONOUT + ;CALL + + RET + +; read a 512-byte-block from the card +; args: block number +; returns: 0 on success +CARDREADBLK: + LOADC 128 ; number of words in a block + SWAP ; move block number up the stack + LOADCP CARD_BUF + SWAP + LOADC 0 + SWAP + LOADC 17 ; CMD17: read block + LOADCP SENDCMD_PKT + CALL + RET + +; determine number of blocks +; returns: number of blocks or -1 on error +CARDSIZE: + LOADC 4 + LOADCP CSD_BUF + LOADC 0 + LOADC 0 + LOADC 9 + LOADCP SENDCMD_PKT ; send CMD9 + CALL + + CBRANCH.NZ CARDSIZE_ERR ; if response is zero, an error occurred + + ; take bytes 7, 8 and 9 from CSD data + ; and add 1 to get card size in ksectors + LOADCP CSD_BUF + INC 4 + LOADI + LOADC $3F ; get byte 7 (bits 22-16) + AND + BROT + BROT + + LOADCP CSD_BUF ; get bytes 8 and 9 (bits 15-0) + INC 8 + LOADI + BROT + BROT + LOADCP $FFFF + AND + + OR + + INC 1 + + BROT + SHL 2; multiply by 1024 to get size in sectors + + RET + +CARDSIZE_ERR: + LOADC -1 + RET + +; returns 1 if the card was changed, 0 otherwise +CARDCHANGED: + LOADCP SPIREG + LOADI + LOADCP SPI_C_CHG + AND + LOADC 0 + CMPU NE + RET + +; write a 512-byte-block to the card +; args: block number +; returns: 0 on success +CARDWRITEBLK: + LOADC 128 ; number of words in a block + SWAP ; move block number up the stack + LOADCP CARD_BUF + SWAP + LOADC 0 + SWAP + LOADC 24 ; CMD24: write block + LOADCP SENDCMD_TXPKT + CALL + RET +; send the card initialization command +; wait until the card responds +CARDINITV2: + LOADC 100 ; try up to 100 times +CARD_LOOP1: + LOADC 50 ; wait 50 msec +CARD_LOOP2: + LOADCP WAIT1MSEC + CALL + DEC 1 + DUP + CBRANCH.NZ CARD_LOOP2 + DROP ; remove loop count value + + LOADC $0 + LOADC $0 + LOADC 58 + LOADCP SENDCMD_R7 ; send CMD58 + CALL + DROP ; ignore result (why?) + + LOADC $0 + LOADCP $40000000 + LOADC 41 + LOADCP SENDACMD_R1 ; send ACMD41 + CALL + + CBRANCH.Z CARD_OK ; if result is zero, the command succeded + ; and the card initialization is finished + DEC 1 + DUP + CBRANCH.NZ CARD_LOOP1 + DROP ; remove outer loop count value + + RET +CARD_OK: + DROP ; remove outer loop count value + + ; CMD16: set block size to 512 byte + LOADC 0 + LOADC 512 + LOADC 16 + LOADCP SENDCMD_R1 + CALL + DROP ; ignore return value + + RET + +; set fast transfer rate +CARDFASTCLK: + LOADC SPIREG + ; set clock divider to ~2,6MHz + LOADCP SPI_CLK_DIV_WR,10 ; using the LOADCP with offset syntax here + STOREI + DROP + RET + +; perform first phase of card initialization +; which is to enable clock and wait a bit +; leaves the clock running +_SPIINIT1: + LOADC SPIREG + ; set clock divider to ~325KHz + LOADCP SPI_CLK_DIV_WR,64 ; LOADCP with offset + STOREI + DROP + + ; clear all flags + enable clock + ; /CS and MOSI are default high + LOADC SPIREG + LOADCP SPI_CTRL_WRITE,SPI_CLK_F_EN + STOREI + DROP + + ; we should wait at least for 74 clock cycles now + LOADC 2 ; wait 2 msec, that should be ~300 cycles +_SPIINIT1L: + LOADCP WAIT1MSEC + CALL + DEC 1 + DUP + CBRANCH.NZ _SPIINIT1L + DROP + + LOADC SPIREG + LOADCP SPI_CTRL_WRITE ; disable clock + STOREI + DROP + + LOADCP WAIT1MSEC + CALL + + RET + +; wait for transmission to finish +; (wait for TX_EMPTY bit) +_SPIWAITTX: + LOADC SPIREG + LOADI + LOADCP SPI_TX_EMPTY + AND + CBRANCH.Z _SPIWAITTX + RET + +; finalize a command that has been sent: +; wait until the transmitter is idle +; then disable clock and set MOSI high +_SPIENDCMD: + LOADCP $FF + LOADCP _SENDBYTE + CALL + LOADCP $FF + LOADCP _SENDBYTE + CALL + + ;LOADC 'E' + ;LOADCP CONOUT + ;CALL + + LOADCP _SPIWAITTX + CALL + + ;LOADC 'w' + ;LOADCP CONOUT + ;CALL + LOADCP _WAIT_S ; wait a short time + CALL + + LOADC SPIREG + LOADCP SPI_IDLE_FLAGS ; turn off transceiver + LOADI + STOREI + DROP + + ; wait for a few instructions + LOADC 100 +SPIEND_LP: DEC 1 + DUP + CBRANCH.NZ SPIEND_LP + DROP + + RET + +_WAIT_S: + LOADC 100 +_WAIT_S_L: + DEC 1 + DUP + CBRANCH.NZ _WAIT_S_L + DROP + RET + +; clear RX fifo +CLEAR_RX_FIFO: +CLEAR_RX_L1: + LOADC SPIREG + LOADI + + ;DUP + ;LOADCP PRINTHEXW + ;CALL + ;LOADCP NEWLINE + ;CALL + + LOADC SPI_RX_AVAIL + AND + CBRANCH.Z CLEAR_RX_X + LOADC SPIREG + LOADC SPI_RX_RD + STOREI + DROP + + ; FIXME: it seems that this + ; does not remove a byte from the fifo, + ; rx_avail stays on, but only after the first + ; byte has been received and read + + ;LOADC 'x' + ;LOADCP CONOUT + ;CALL + + BRANCH CLEAR_RX_L1 +CLEAR_RX_X: + RET + +_WAITSPITXRDY: + LOADC SPIREG + LOADI + LOADCP SPI_TX_RDY + AND + CBRANCH.Z _WAITSPITXRDY + RET + +; send a command and receive a data packet response +; args: packet size in words, buffer pointer +; checksum byte, 32-bit cmd arg, cmd number +; returns: 0 on success +SENDCMD_PKT: + ; first send the command + LOADCP SENDCMD_0 + CALL + + LOADCP _RCVBYTE ; receive R1 response + CALL + + CBRANCH.NZ SENDCMD_PKT_E ; on success we get 0 + + ; now wait for data token +SENDCMD_PKT_L: + LOADCP _RCVBYTE + CALL + LOADC $FF + CMP EQ + CBRANCH SENDCMD_PKT_L + + ; parameters for _RCVWORDS are on the stack now + LOADCP _RCVWORDS + CALL + + ; receive 2 crc bytes + LOADCP _RCVBYTE + CALL + BROT + LOADCP _RCVBYTE + CALL + OR + + ; terminate command + LOADCP _SPIENDCMD + CALL + + DROP ; we ignore the checksum for now + + LOADC 0 + RET +SENDCMD_PKT_E: + DROP ; remove remaining args + DROP + LOADC -1 ; return code for error + RET + +; send a command and send a data packet +; args: packet size in words, buffer pointer +; checksum byte, 32-bit cmd arg, cmd number +; returns: 0 on success +SENDCMD_TXPKT: + ; first send the command + LOADCP SENDCMD_0 + CALL + + ;LOADCP _RCVBYTE + ;CALL + ;DROP ; remove byte received during transmit + + LOADCP _RCVBYTE ; receive R1 response + CALL + + CBRANCH.NZ SENDCMD_TXPKT_E ; on error we get nonzero + + ; send stuff byte + LOADC $FF + LOADCP _SENDBYTE + CALL + + ; now send data token + LOADCP %11111110 + LOADCP _SENDBYTE + CALL + + ; send data block + ; parameters for _SENDWORDS are on the stack now + LOADCP _SENDWORDS + CALL + + ; send 2 dummy crc bytes + LOADC 0 + LOADCP _SENDBYTE + CALL + LOADC 0 + LOADCP _SENDBYTE + CALL + + ;receive data response byte +SENDCMD_TXPKT_LR: + LOADCP _RCVBYTE + CALL + LOADC $FF ; discard $FF bytes + CMP.S0 NE + CBRANCH SENDCMD_TXPKT_CT + DROP + BRANCH SENDCMD_TXPKT_LR + +SENDCMD_TXPKT_CT: + LOADC $1F + AND ; isolate status bits + LOADC $5 ; command accepted bit set? + CMP NE ; if not, exit with error + CBRANCH SENDCMD_TXPKT_E2 + + ; wait until card is busy +SENDCMD_TXPKT_LB: + LOADCP _RCVBYTE ; receive byte + CALL + CBRANCH.NZ SENDCMD_TXPKT_LB ; loop until byte is 0 + ; wait until card is not busy +SENDCMD_TXPKT_L2: + LOADCP _RCVBYTE ;receive byte + CALL + CBRANCH.Z SENDCMD_TXPKT_L2 ; loop if byte is 0 (i.e. MISO is held low) + + LOADC 0 + BRANCH SENDCMD_TXPKT_X + +SENDCMD_TXPKT_E: + DROP ; remove remaining args + DROP +SENDCMD_TXPKT_E2: + LOADC -1 ; return code for error +SENDCMD_TXPKT_X: + ; terminate command + LOADCP _SPIENDCMD + CALL + + RET + +; send a command and receive a 1-byte-response (R1) +; args: checksum byte, 32-bit cmd arg, cmd number +; returns: received byte +SENDCMD_R1: + LOADCP SENDCMD_0 + CALL + + LOADCP _RCVBYTE + CALL + + ;LOADC 'R' + ;LOADCP CONOUT + ;CALL + + ;terminate command (/cs high, disable clock) + LOADCP _SPIENDCMD + CALL + + RET + +; send a command +; args: checksum byte, 32-bit cmd arg, cmd number +SENDCMD_0: + ; clear RX FIFO first + LOADCP CLEAR_RX_FIFO + CALL + + ;LOADC '>' + ;LOADCP CONOUT + ;CALL + + ; cmd byte is at TOS at this point + LOADC $40 ; or in start of frame bit + OR + LOADCP _SENDBYTE + CALL + ; cmd arg is at TOS now + LOADCP _SENDWORD + CALL + ; checksum byte is at TOS now + LOADCP _SENDBYTE + CALL + + LOADCP _XCVR_ENABLE ; enable transceiver last, + CALL ; a complete command should + RET ; fit into the tx fifo + +; send ACMD and receive a 1-byte-response (R1) +; args: checksum byte, 32-bit cmd arg, ACMD number +; returns: received byte or -1 if first response byte +; indicated an error +SENDACMD_R1: + LOADC $0 + LOADC $0 + LOADC 55 ; send CMD55 + LOADCP SENDCMD_R1 + CALL + + LOADC 1 ; 1 = idle state, no errors + CMP NE + CBRANCH.NZ SENDACMD_ERR + + ; pass our args to SENDCMD_R1 + LOADCP SENDCMD_R1 + CALL + RET + +SENDACMD_ERR: + LOADCP -1 + RET + +; send a command and receive a 4+1-byte-response (R7) +; args: checksum byte, 32-bit cmd arg, cmd number +; returns: received word or -1 if first response byte +; indicated an error + +SENDCMD_R7: + ; send the command + LOADCP SENDCMD_0 + CALL + + ;LOADC '7' + ;LOADCP CONOUT + ;CALL + + LOADCP _RCVBYTE + CALL + + LOADCP _RCVWORD + CALL + + ;terminate command (/cs high, disable clock) + LOADCP _SPIENDCMD + CALL + + SWAP ; swap 1st response byte with received word + LOADC %011111110 ; check for any error flags + AND + CBRANCH.Z SENDCMD_R7_NOERR + DROP + LOADC -1 +SENDCMD_R7_NOERR: + RET + +; send a word as 4 bytes, msb first +_SENDWORD: + DUP ; remember original value for later + + BROT ; rotate msb to lsb (byte 0) + LOADC 255 + AND.S0 ; isolate byte, keep previous value + LOADCP _SENDBYTE + CALL + + BROT ; byte 1 + LOADC 255 + AND.S0 + LOADCP _SENDBYTE + CALL + + BROT ; byte 2 + LOADC 255 + AND + LOADCP _SENDBYTE + CALL + + ; byte 3 is already on the stack + LOADC 255 + AND + LOADCP _SENDBYTE + CALL + + RET + +; send multiple 4-byte-words +; args: number of words, pointer to buffer +_SENDWORDS: + FPADJ -4 + STORE 0 ; store pointer arg into local variable + ; keep counter on stack +_SENDWORDS_LP: + LOAD 0 ; load buf pointer + DUP ; duplicate it + INC 4 ; increment pointer + STORE 0 ; and store it back + LOADI ; load from previously duped pointer + LOADCP _SENDWORD + CALL ; send a word + + DEC 1 ; decrement word counter + DUP + CBRANCH.NZ _SENDWORDS_LP ; if not null, loop + DROP ; remove counter value + + FPADJ 4 + RET + +; receive multiple 4-byte-words and store into +; memory buffer +; args: number of words, pointer to buffer +_RCVWORDS: + FPADJ -4 + STORE 0 ; store pointer arg into local variable + ; keep counter on stack +_RCVWORDS_LP: + LOAD 0 ; load buf pointer for STOREI + LOADCP _RCVWORD + CALL ; receive a word + STOREI 4 ; store to buf with postincrement + STORE 0 ; store pointer variable + + DEC 1 ; decrement word counter + DUP + CBRANCH.NZ _RCVWORDS_LP ; if not null, loop + DROP ; remove counter value + + FPADJ 4 + RET + +; receive 4 bytes, return as word +_RCVWORD: + LOADCP _RCVBYTE ; receive first byte + CALL + BROT ; rotate byte to left + + LOADCP _RCVBYTE ; receive second byte + CALL + OR ; or first and second byte together + BROT ; rotate 1st + 2nd to left + + LOADCP _RCVBYTE ; receive third byte + CALL + OR + BROT + + LOADCP _RCVBYTE ; receive fourth byte + CALL + OR + RET + +_XCVR_ENABLE: + LOADC SPIREG + LOADCP SPI_TX_FLAGS + LOADI + STOREI + DROP + RET + +; send a byte +; args: byte to be sent +_SENDBYTE: + LOADC SPIREG + LOADI ; load spi io register + LOADCP SPI_TX_RDY + AND ; check tx_rdy bit + CBRANCH.Z _SENDBYTE ; if not set, loop + + LOADC SPI_TX_WR ; TX_WR bit + OR ; OR in byte to be send + + LOADC SPIREG + SWAP ; swap value and addr for STOREI + STOREI ; store word (flags + data) to io register + DROP ; remove STOREI result + + RET + +; receive a byte. receiver must be enabled. +; returns: received byte +_RCVBYTE: + LOADC SPIREG + LOADI ; load spi io register + LOADC SPI_RX_AVAIL + AND.S0 ; check rx_avail bit, keep original value + CBRANCH.NZ RECV_GOTIT + DROP ; rx_avail not set, remove register value and loop + BRANCH _RCVBYTE +RECV_GOTIT: + LOADC SPIREG + LOADC SPI_RX_RD ; remove one byte from rx fifo + STOREI + DROP + + LOADC 255 + AND ; keep bits 7-0 + RET + +SPI_TX_FLAGS: .WORD SPI_CTRL_WRITE + SPI_TXRX_EN + SPI_RX_FILTER_EN +SPI_IDLE_FLAGS: .WORD SPI_CTRL_WRITE + + .CPOOL + +CSD_BUF: .BLOCK 4 +CARD_BUF: .BLOCK 128 + diff --git a/lib/stdlib.inc b/lib/stdlib.inc new file mode 100644 index 0000000..32aedd9 --- /dev/null +++ b/lib/stdlib.inc @@ -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; diff --git a/lib/stdlib.pas b/lib/stdlib.pas new file mode 100644 index 0000000..c1da7de --- /dev/null +++ b/lib/stdlib.pas @@ -0,0 +1,2710 @@ +(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *) +unit stdlib; +implementation + +const precision = 7; + pi = 3.14159263; + +const MaxInt = 2147483647; + YearBias = 1970; + +const TicksPerSec = 20; + +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 *) + 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; +var DefaultVolumeId:integer; + VolumeTable: array [1..MaxVolumes] of Volume; + VolumeCount: integer; + DevicesInitialized: boolean; + + (* the max string length must be at least one byte + larger than the longest initialization value, + so that we have a zero byte at the end + and we can pass the address of the first + character to the runtime error routine + which takes null-terminated strings. + *) +var ioerrordesc: array [0..11] of string[20] = ( + 'No error', + 'File not found', + 'Volume not found', + 'Path invalid', + 'File already exists', + 'File closed', + 'Seek invalid', + 'No space', + 'File is readonly', + 'Invalid operation', + 'Invalid format', + 'Interrupted by user' + ); + + matherror:string[38] = 'Invalid argument to sqrt/ln/tan/cotan'; + pexecerror:string[28]= 'Invalid arguments for PExec'; + + random_state:integer; + + PArgs:array [0..PArgMax] of string external; + PArgCount:integer external; + + ShellCmd: string[40] external; + ShellArg: integer external; + + DefaultVolume: volumenamestr external; + +var DateTimeMTab: array[0..1, 1..12] of integer = ( + (31,28,31,30,31,30,31,31,30,31,30,31), + (31,29,31,30,31,30,31,31,30,31,30,31) + ); + +var SysBootTicks, SysLastTicks:integer external; + SysClock:DateTime external; + + +FUNCTION LENGTH(s:STRING):INTEGER; EXTERNAL; +FUNCTION MAXLENGTH(s:STRING):INTEGER; EXTERNAL; +procedure appendchar(var s:string; aChar:char); external; +procedure RuntimeError(var s:string); external; +procedure coreload(devId:integer; physBlock:integer; sizeBytes:integer); external; +procedure initsdcard; 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 writepartblk(blkno:integer;var partblk:PartitionTableBlock; + var error:integer;devid: integer); external; +procedure writedirblk(blkno:integer;var dirblk:DirBlock; + 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 writechanwords(var f:file; src: ^IOBuffer; wordCount:integer); external; +procedure readchanwords(var f:file; src: ^IOBuffer; wordCount:integer); external; + +function conin():char; external; +procedure conout(c:char); external; + +function shiftfloat32(aReal:real; shiftCount:integer):real; external; +function getfloat32exp(aReal:real):integer; external; + +procedure conoutw(w:integer); external; +function coninw():integer; external; + +function getticks():integer; external; +procedure wait1msec; external; + +procedure writechannel(var f:file; aChar:char); forward; +function eof(var fil:file):boolean; forward; +function eoln(var fil:file):boolean; forward; +function freadchar(var f:file):char; forward; +procedure pushback(var aFile:file; aChar:char); forward; +procedure fileerror(var fil:file; error:integer); forward; +procedure initDevices; forward; +function findvolume(name:string):integer; forward; + +procedure AdvanceTime(var d:DateTime;seconds:integer); +var secsRest, minutesRest, hoursRest:integer; + newSecs, newMinutes, newHours:integer; + newDays, newMonth, newYear:integer; + minutesDelta, hoursDelta, daysDelta:integer; + mpdIndex, daysPerMonth:integer; + +function isLeapYear:boolean; +begin + isLeapYear := ((newYear mod 4) = 0) + and ((newYear mod 100) <> 0) + or ((newYear mod 400) = 0); +end; + +begin + + secsRest := seconds mod 60; + minutesDelta := seconds div 60; + minutesRest := minutesDelta mod 60; + + newSecs := d.seconds + secsRest; + if newSecs >= 60 then + begin + newSecs := newSecs - 60; + minutesDelta := minutesDelta + 1; + minutesRest := minutesRest + 1; + end; + d.seconds := newSecs; + + hoursDelta := minutesDelta div 60; + hoursRest := hoursDelta mod 24; + + newMinutes := d.minutes + minutesRest; + if newMinutes >= 60 then + begin + newMinutes := newMinutes - 60; + hoursDelta := hoursDelta + 1; + hoursRest := hoursRest + 1; + end; + d.minutes := newMinutes; + + daysDelta := hoursDelta div 24; + newHours := d.hours + hoursRest; + if newHours >= 24 then + begin + newHours := newHours - 24; + daysDelta := daysDelta + 1; + end; + d.hours := newHours; + + newDays := d.day + daysDelta; + + newMonth := d.month; + newYear := d.year; + + if isLeapYear then + mpdIndex := 1 + else + mpdIndex := 0; + + daysPerMonth := DateTimeMTab[mpdIndex][newMonth]; + while newDays > daysPerMonth do + begin + newMonth := newMonth + 1; + newDays := newDays - daysPerMonth; + + if newMonth > 12 then + begin + newYear := newYear + 1; + newMonth := 1; + if isLeapYear then + mpdIndex := 1 + else + mpdIndex := 0; + end; + daysPerMonth := DateTimeMTab[mpdIndex][newMonth]; + end; + + d.day := newDays; + d.month := newMonth; + d.year := newYear; +end; + +function GetTime:DateTime; +var now,delta:integer; + secs:integer; +begin + if SysClock.year = 0 then + begin + SysClock.year := 2001; + SysClock.month := 1; + SysClock.day := 1; + end; + + now := GetTicks; + delta := now - SysLastTicks; + SysLastTicks := now; + secs := delta div TicksPerSec; + AdvanceTime(SysClock, secs); + GetTime := SysClock; +end; + +function TimeStr(d:DateTime;showSeconds:boolean):string; +var digits:string[4]; +begin + str(d.hours,digits); + if d.hours<10 then + TimeStr := '0'; + TimeStr := TimeStr + digits + ':'; + + str(d.minutes,digits); + if d.minutes<10 then + appendchar(TimeStr,'0'); + TimeStr := TimeStr + digits; + + if showSeconds then + begin + appendchar(TimeStr, ':'); + str(d.seconds,digits); + if d.seconds<10 then + appendchar(TimeStr,'0'); + TimeStr := TimeStr + digits; + end; +end; + +function DateStr(d:DateTime):string; +var digits:string[4]; +begin + str(d.year,digits); + DateStr := DateStr + digits + '-'; + + str(d.month,digits); + if d.month<10 then + appendchar(DateStr,'0'); + DateStr := DateStr + digits; + + appendchar(DateStr, '-'); + str(d.day,digits); + if d.day<10 then + appendchar(DateStr,'0'); + DateStr := DateStr + digits; +end; + +function GetTimestamp(var d:DateTime):Timestamp; +var i:Timestamp; +begin + i := (d.year - YearBias) shl 24; + i := i or (d.month shl 20); + i := i or (d.day shl 15); + i := i or (d.hours shl 10); + i := i or (d.minutes shl 4); + i := i or (d.seconds shr 2); (* seconds / 4 *) + GetTimestamp := i; +end; + +function GetDateTime(ts:Timestamp):DateTime; +begin + GetDateTime.seconds := (ts and $0F) shl 2; + ts := ts shr 4; + + GetDateTime.minutes := ts and $3F; + ts := ts shr 6; + + GetDateTime.hours := ts and $1F; + ts := ts shr 5; + + GetDateTime.day := ts and $1F; + ts := ts shr 5; + + GetDateTime.month := ts and $0F; + ts := ts shr 4; + + GetDateTime.year := YearBias + (ts and $FF); +end; + +function GetCurTimestamp:Timestamp; +var now:DateTime; +begin + now := GetTime; + GetCurTimestamp := GetTimestamp(now); +end; + +function copy(s:string;index,count:integer):string; +var len:integer; +begin + copy := ''; + len := length(s); + if index < 1 then index := 1; + while (count > 0) and (index <= len) do + begin + copy := copy + s[index]; + index := index + 1; + count := count - 1; + end; +end; + +procedure insert(ins: string; var dest: string; position:integer); +var i,count,from,to_:integer; +begin + if position < 1 then position := 1; + if position > length(dest) + 1 then position := length(dest) + 1; + + from := length(dest); + count := length(dest) - position + 1; + to_ := from + length(ins); + setlength(dest, length(dest) + length(ins)); + + for i := 1 to count do + begin + if to_ <= maxlength(dest) then + begin + dest[to_] := dest[from]; + to_ := to_ - 1; + from := from - 1; + end; + end; + + to_ := position; + + count := length(ins); + for i := 1 to count do + begin + if to_ <= maxlength(dest) then + begin + dest[to_] := ins[i]; + to_ := to_ + 1; + end; + end; +end; + +procedure delete(var s:string; from:integer; count:integer); +var i,len,last:integer; +begin + len := length(s); + if (from > 0) and (from <= len) and (count > 0) then + begin + if from + count <= len then + begin + last := len - count; + for i := from to last do + s[i] := s[i+count]; + end + else + last := from - 1; + + setlength(s,last); + end; +end; + +(* Find a substring inside a string, return the + index of the character where the substring was found, + or zero if the substring was not found. + + The substring is passed by value, so you can pass a + string literal. The string to be searched in is passed + as a var parameter for speed. + + That means you cannot use pos to search inside a string + literal. Hopefully this is not something you want to do. + *) +function pos(substr:string;var s:string):integer; +var substrlen:integer; + slen:integer; + searchpos:integer; + subchar:char; + subpos:integer; + found:boolean; + i:integer; + +begin + found := false; + substrlen := length(substr); + slen := length(s); + + searchpos := 1; + subpos := 1; + + if(substrlen > 0) and (slen>0) then + begin + while not found and (searchpos <= slen) do + begin + (* compare character by character *) + if substr[subpos] <> s[searchpos] then + begin + (* If a character does not match, reset the + character index of the substring. + Go to the next character of the searched + string only if we are already at the + beginning of the substring. + Otherwise we need to check the current character + against the first character of the substring. *) + + if subpos = 1 then + searchpos := searchpos + 1; + subpos := 1; + end + else + begin + (* character does match *) + if subpos = 1 then + (* remember start of this search attempt *) + pos := searchpos; + + (* if this was the last character of the substring, + we are successful *) + if subpos = substrlen then + found := true + else + begin + (* else go to next characters *) + subpos := subpos + 1; + searchpos := searchpos + 1; + end; + end; + end; + end; + + if not found then + pos := 0; +end; + +function pwroften(exp:integer):real; +var i:integer; + res:real; + sofar:integer; +begin + if exp = 0 then + res := 1 + else if exp = 1 then + res := 10 + else + begin + sofar := 1; + res := 10; + while sofar shl 1 <= exp do + begin + res := res * res; + sofar := sofar shl 1; + end; + for i := sofar + 1 to exp do res := res * 10; + end; + + pwroften := res; +end; + +(* calculate the power of e using a Taylor series *) +function exp(exponent:real):real; +var x,p,frc,i,l:real; +begin + x := exponent; + frc := x; + p := 1.0 + x; + i := 1.0; + + repeat + i := i + 1.0; + frc := frc * (x / i); + l := p; + p := p + frc; + until l = p; + + exp := p; +end; + +(* + calculate natural logarithm + see https://stackoverflow.com/a/71994145 + no idea what algorithm this is :/ +*) +function ln(n:real):real; +const euler = 2.7182818284590452354; +var a,b:integer; + c,d,e,f:real; + cn:real; +begin + a := 0; + + if n > 0 then + begin + d := n / euler; + while d > 1.0 do + begin + a := a + 1; + n := d; + d := n / euler; + end; + d := n * euler; + while d < 1.0 do + begin + a := a - 1; + n := d; + d := n * euler; + end; + + d := 1.0 / (n - 1); + d := d + d + 1.0; + e := d * d; + c := 0; + + b := 1; + f := 1.0; + cn := c + 1.0 / (b * f); + while (c + 0.00001) < cn do + begin + c := cn; + b := b + 2; + f := f * e; + cn := c + 1.0 / (b * f); + end; + c := cn * 2.0 / d; + + end + else + RuntimeError(matherror); + + ln := a + c; +end; + +(* calculate square root via Newton-Raphson method *) +function sqrt(n:real):real; +var error:real; + guess, newGuess:real; + diff, lastDiff:real; +begin + if n < 0.0 then + RuntimeError(matherror) + else + if n = 0.0 then + sqrt := 0.0 + else + begin + guess := n / 2.0; + error := n / 100000; (* adapt the acceptable error to the argument *) + + diff := 0.0; + + repeat + lastDiff := diff; + (* newGuess := (guess + n/guess) / 2; *) + (* a slight performance improvement by using shiftfloat + instead of division *) + newGuess := shiftfloat32(guess + n/guess, -1); + diff := abs(newGuess - guess); + guess := newGuess; + (* we stop if the difference to the last guess is below + the acceptable error threshold, if we somehow + hit zero, or if the last difference is exactly the + same as the new one *) + until (diff < error) or (guess = 0.0) or (diff = lastDiff); + + sqrt := guess; + end; +end; + +function floor(x:real):integer; +begin + if x < 0.0 then + (* -3.7 gets floored to -4.0 *) + x := x - 0.9999999; + + floor := trunc(x); +end; + + +function round(x:real):integer; +begin + round := trunc(x+0.5); +end; + +function sin(x:real):real; +var k,y:real; + quadrant:integer; + invert:boolean; +const twobypi = 0.6366198; + pihalf = 1.5707963; + + function sin_taylor(x:real):real; + var x2,x3,x5:real; + begin + x2 := x * x; + x3 := x2 * x; + x5 := x3 * x2; + + sin_taylor := x - x3 / 6.0 + x5 / 120.0; + end; + +begin + if x < 0 then + begin + x := -x; + invert := true; + end + else + invert := false; + + k := floor( x * twobypi); + y := x - k * pihalf; + + quadrant := trunc(k) mod 4; + + case quadrant of + 0: sin := sin_taylor(y); + 1: sin := sin_taylor(pihalf - y); + 2: sin := -sin_taylor(y); + 3: sin := -sin_taylor(pihalf - y); + end; + + if invert then + sin := -sin; +end; + +function cos(x:real):real; +const pihalf = 1.57079632; +begin + cos := sin(x + pihalf); +end; + +(* arctan and tancot implemented after + "Methods and programs for mathematical functions" + by Stephen L. Moshier + and the Cephes mathematical library by the same author. +*) + +function arctan(x:real):real; +const tan3pi8 = 2.14121356; + tanpi8 = 0.41421356; + pihalf = 1.57079632; + piquart = 0.78539816; +var y,z:real; + negate:boolean; +begin + if x < 0.0 then + begin + x := -x; + negate := true; + end + else + negate := false; + + if x > tan3pi8 then + begin + y := pihalf; + x := -(1.0/x); + end + else + if x > tanpi8 then + begin + y := piquart; + x := (x-1.0)/(x+1.0); + end + else + y := 0.0; + + z := x * x; + y := y + + ((( 8.05374449538e-2 * z + - 1.38776856032E-1) * z + + 1.99777106478E-1) * z + - 3.33329491539E-1) * z * x + + x; + + if negate then + y := -y; + arctan := y; +end; + +function tancot(x:real; doCot:boolean):real; +const DP1 = 0.78515625; + DP2 = 2.41875648e-4; + DP3 = 3.77489497e-8; + FOPI = 1.27323954; + lossth = 8192.0; +var y,z,zz:real; + j:integer; + negate:boolean; +begin + if x < 0 then + begin + x := -x; + negate := true; + end + else + negate := false; + + if x > lossth then + RuntimeError(matherror); + + j := trunc(FOPI * x); + y := j; + + if (j and 1) <> 0 then + begin + j := j + 1; + y := y + 1.0; + end; + + z := ((x - y * DP1)- y * DP2) - y * DP3; + zz := z * z; + + if x > 1.0E-4 then + begin + y :=((((( 9.38540185543E-3 * zz + + 3.11992232697E-3) * zz + + 2.44301354525E-2) * zz + + 5.34112807005E-2) * zz + + 1.33387994085E-1) * zz + + 3.33331568548E-1) * zz * z + + z; + end + else + y := z; + + if (j and 2) <> 0 then + begin + if doCot then + y := -y + else + y := -1.0/y; + end + else + if doCot then + y := 1.0/y; + + if negate then + y := -y; + + tancot := y; +end; + +function tan(x:real):real; +begin + tan := tancot(x, false); +end; + +function cotan(x:real):real; +begin + cotan := tancot(x, true); +end; + +procedure fillchar(var s:string; startpos,count:integer; theChar:char); +var i:integer; + endpos:integer; + p1:integer; +begin + endpos := length(s); + setlength(s, endpos + count); + p1 := startpos + count; + + for i := endpos downto startpos do + s[i+count] := s[i]; + + p1 := p1 - 1; + for i := startpos to p1 do + s[i] := theChar; +end; + +procedure intstr(v:integer;fieldWidth:integer;var rbuf:string); +var buf:string[12]; (* signed 32 bit number can have at most 10 digits *) + digit:integer; + i:integer; + isNegative:boolean; +begin + buf := ''; + isNegative := false; + + (* special case for smallest integer + which we cannot negate *) + if v = -2147483648 then + begin + buf := '8463847412'; + isNegative := true; + end + else + begin + if v < 0 then + begin + isNegative := true; + v := -v; + end; + + repeat + digit := v mod 10; + v := v div 10; (* this could be a single DIVMOD call in assembly *) + buf := buf + chr(digit + 48); (* ascii code for '0' *) + until v = 0; + end; + + rbuf := ''; + if isNegative then + rbuf := rbuf + '-'; + + (* field width is used by str() special procedure *) + if fieldWidth > length(rbuf) then + fillchar(rbuf, 1, fieldWidth - length(rbuf), ' '); + + for i := length(buf) downto 1 do + rbuf := rbuf + buf[i]; +end; + +procedure realstr(x:real; w, d: integer; var s: string[30]); +var j, truncx, expx: integer; + normx: real; +begin + (* check w and d for validity *) + if (w < 0) or (d < 0) then + begin w := 0; d := 0 end; + + (* take abs(x), normalize it and calculate exponent *) + if x < 0 then + begin x := -x; s := '-' end + else + s := ' '; + + expx := 0; normx := x; + + if x >= 1.0 then (* divide down to size *) + while normx >= 10.0 do + begin + expx := expx+1; + normx := x/pwroften(expx) + end + else + if x <> 0 then (* multiply up to size *) + repeat + expx := expx-1; normx := x*pwroften(-expx) + until normx >= 1; + + (* round number according to some very tricky rules *) + if (d=0) or (d+expx+1 > precision) then (* scientific notation, or decimal places *) + normx := normx + 5/pwroften(precision) (* overspecified *) + else if d+expx+1 >= 0.0 then + normx := normx + 5/pwroften(d+expx+1); + (* if d+expx+1 < 0, then number is effectively 0.0 *) + + (* if we just blew normalized stuff then fix it up *) + if normx >= 10.0 then + begin expx := expx+1; normx := normx/10.0 end; + + (* put the digits into a string *) + for j := 1 to precision do + begin + truncx := trunc(normx); + s := s + chr(truncx+ord('0')); + normx := (normx-truncx)*pwroften(1) + end; + + (* put number into proper form *) + if (d=0) or (expx >= 6) then (* scientific notation *) + begin + insert('.', s, 3); + if expx <> 0 then + begin + s := s + 'E'; + if expx < 0 then + begin s := s + '-'; expx := -expx end; + if expx > 9 then + s := s + chr(expx div 10 + ord('0')); + s := s + chr(expx mod 10 + ord('0')) + end; + end + else (* some kind of fixed point notation *) + if expx >= 0 then + begin + insert('.', s, 3+expx); + for j := 1 to d-(5-expx) do + s := s + ' '; (* add blanks if over-precision *) + setlength(s, 3 + expx + d); (* 6 digits after point, 3 + exp chars before *) + end + else + begin + insert('0.',s,2); + for j := 1 to -expx-1 do + insert('0',s,4); (* leading zeroes *) + setlength(s, 3 + d); (* 3 chars before point *) + + (* fillchar(s[9-expx], d-6+expx, ' ');*) (* put in blanks for over-precision*) + end; + + if w > length(s) then + fillchar(s, 1, w - length(s), ' '); +end; + + +function isdigit(aChar:char):boolean; +begin + isdigit := (aChar >= '0') and (aChar <= '9'); +end; + +function iswhite(aChar:char):boolean; +begin + iswhite := aChar in [ #32, #9, #13, #10 ]; +end; + +procedure skipwhite(var s:string;var i:integer); +var l:integer; + c:char; +begin + for c in s do + if not (c in [ #10, #13, #32, #9 ]) then + break + else + i := i + 1; +end; + +procedure intval(s:string; var value,code:integer); +var i,v,l,d:integer; + digit:char; + negate:boolean; + valid:boolean; +begin + i := 1; v := 0; l := length(s); + negate := false; valid := false; + skipwhite(s,i); + code := l+1; (* for an empty string, we return a position after the end *) + + if length(s) >= i then + begin + digit := s[i]; + if digit = '-' then + begin + negate := true; + i := i + 1; + end + else + if digit = '+' then + i := i + 1; + + while (i <= l) do + begin + digit := s[i]; + valid := isdigit(digit); + if valid then + begin + d := ord(digit) - ord('0'); + v := v * 10 + d; + end + else + begin + (* invalid digit, set error position *) + code := i; + break; + end; + i := i + 1; + end; + end; + + if valid and (i = l + 1) then + (* if we are after the end of the string and have a valid result *) + begin + if negate then + value := -v + else + value := v; + code := 0; + end; +end; + +procedure realval(s:string;var v:real;var code:integer); +label ext; +var ch: char; neg,xvalid: boolean; ipot: integer; + x:real; + i:integer; + feof: boolean; + digitval:real; + +function nextchar:char; +begin + if i<=length(s) then + begin + nextchar := s[i]; + i := i + 1; + feof := false; + end + else + begin + nextchar := #0; + feof := true; + end; +end; + +procedure sreadint(var e:integer); +var digits: string[4]; + status: integer; +begin + e := 0; + digits := copy(s, i , 4); + intval(digits,e,status); + if status <> 0 then + begin + (* + writeln('***sreadint error at ', status, ' for ', digits, + ' ', length(digits), ' ', i); *) + i := i + status; + xvalid := false; + end + else + i := i + length(digits); +end; + +begin + i := 1; + x := 0; neg := false; xvalid := false; + + skipwhite(s,i); + + ch := nextchar; + if (ch = '+') or (ch = '-') then + begin + neg := ch = '-'; + ch := nextchar + end; + + while isdigit(ch) and not feof do + begin + xvalid := true; + x := x*10 + (ord(ch)-ord('0')); + ch := nextchar; + end; + if feof then goto ext; + + ipot := -1; + if ch = '.' then + begin + ipot := 0; + repeat + ch := nextchar; + if isdigit(ch) then + begin + xvalid := true; ipot := ipot + 1; + digitval := (ord(ch)-ord('0'))/pwroften(ipot); + (* x := x + (ord(ch)-ord('0'))/pwroften(ipot); *) + x := x + digitval; + end + until feof or not isdigit(ch); + if feof then goto ext; + end; + + if ((ch = 'e') or (ch = 'E')) and (xvalid or (ipot < 0)) then + begin + sreadint(ipot); + if feof then goto ext; + if ipot < 0 then + x := x/pwroften(abs(ipot)) + else + x := x*pwroften(ipot); + end; +ext: + (* if processing stopped before the end of string, + we encountered an invalid character, + so we indicate failure *) + if i <= length(s) then + xvalid := false; + + if xvalid then + begin + if neg then x := -x; + v := x; + code := 0; + end + else + code := i - 1; +end; + +procedure checkerror(var fil:file); +begin + if fil.lastError <> 0 then + begin + if not fil.errorAck then + RuntimeError(ioerrordesc[fil.lastError]) + else + begin + fil.lastError := 0; + fil.errorAck := false; + end; + end; +end; + +procedure handleBackspace(var aFile:file; var buf:string; var bytesRemoved:integer); +var len:integer; + removedChar:integer; + highbits:integer; +begin + bytesRemoved := 0; + len := length(buf); + if len > 0 then + begin + if aFile.typ = IOChannel then + begin + (* write BS, space, BS sequence to delete one character *) + writechannel(aFile, #8); + writechannel(aFile, #32); + writechannel(aFile, #8); + end; + repeat + removedChar := ord(buf[len]); + bytesRemoved := bytesRemoved + 1; + len := len - 1; + + (* since a string really contains bytes, not chars, + we need to check for UTF-8-encoded multibyte characters *) + + (* isolate the two leftmost bits of the byte we just removed *) + highbits := removedChar and $C0; + + (* A byte that is part of a multibyte character and is not the + first byte has 10 the two highest bits. + 11 is the first byte of a multibyte character, + a 7-bit ASCII character has 00 or 01.*) + until (highbits <> $80) or (len = 0); + setlength(buf, len); + end +end; + +procedure fscanbuf(var aFile:file; mode: fscanmode; var buf:string); +var bytesRead:integer; + maxBytes:integer; + aChar:char; + done: boolean; + bytesRemoved: integer; + isChannel: boolean; + skipchar: boolean; + +function isSeparator(aChar:char):boolean; +begin + case mode of + ScanInteger: isSeparator := not (isDigit(aChar) or (aChar = '-')); + ScanReal: isSeparator := not (isdigit(aChar) or (aChar in [ '+', '-', '.', 'E', 'e' ])); + ScanString: isSeparator := (aChar = #13) or (aChar = #10); + end; +end; + +begin + maxBytes := maxlength(buf); + bytesRead := 0; done := false; skipchar := false; + buf := ''; + + isChannel := aFile.typ = IOChannel; + + repeat + if eof(aFile) then + done := true + else + begin + aChar := freadchar(aFile); + + if isChannel then + begin + if aChar = #127 then (* DEL *) + begin + if not (aFile.raw or aFile.noecho) then + begin + handleBackspace(aFile, buf, bytesRemoved); + bytesRead := bytesRead - bytesRemoved; + end; + skipchar := true; + end + else if aChar = #4 then (* don't put EOF char into buffer *) + skipchar := true + else + skipchar := false; + end; + + if not skipchar then + begin + if isSeparator(aChar) then + begin + done := true; + pushback(aFile, aChar); + end + else + begin + appendchar(buf, aChar); + bytesRead := bytesRead + 1; + end; + end; + end + if bytesRead = maxBytes then + done := true; + until done; +end; + +procedure fskipwhite(var f:file); +var c:char; +begin + repeat + c := freadchar(f); + until eof(f) or not iswhite(c); + pushback(f, c); +end; + +procedure freadint(var v:integer;var f:file); +var buf:string[24]; + errpos:integer; +begin + errpos := -1; + fskipwhite(f); + fscanbuf(f, ScanInteger, buf); + + if f.lastError = 0 then + val(buf, v, errpos); + if errpos <> 0 then + begin + fileerror(f, IOInvalidFormat); + checkerror(f); + end; +end; + +procedure freadreal(var v:real;var f:file); +var buf:string[40]; + errpos:integer; +begin + fskipwhite(f); + fscanbuf(f,ScanReal, buf); + if f.lastError = 0 then + val(buf, v, errpos); + if errpos <> 0 then + fileerror(f, IOInvalidFormat); +end; + +procedure freadstring(var s:string; var f:file); +begin + fscanbuf(f, ScanString, s); +end; + +procedure skipeoln(var aFile:file); +var aChar:char; +begin + repeat + aChar := freadchar(aFile); + until (aChar = #13) or eof(aFile); + + (* + If it is a disk file, try to read the + LF character that should follow the CR + character. + On a channel (i.e. the console), we + only get the CR character. *) + + if aFile.typ <> IOChannel then + begin + if not eof(aFile) then + begin + aChar := freadchar(aFile); + if aChar <> #10 then + pushback(aFile, aChar); + end; + end; +end; + + +(* + *************** Filesystem ********************************* +*) + +procedure SetDefaultVolume(volname:volumenamestr); +var volid:integer; +begin + volid := findvolume(volname); + if volid > 0 then + begin + DefaultVolume := volname; + DefaultVolumeId := volid; + end; +end; + +procedure addPartitions(devid:integer; var partblk:PartitionTableBlock; var isLast:boolean); +var partNo:integer; + flags:PartFlags; +begin + partNo := 0; + for partNo := 0 to 7 do + begin + flags := partblk[partNo].flags; + if PartLast in flags then isLast := true; + if PartEnabled in flags then + begin + volumeCount := volumeCount + 1; + + with volumeTable[volumeCount] do + begin { + writeln('** addPartitions #', partNo, ' vol #', volumeCount); + writeln('** addPartitions #', partNo, ' start', partblk[partno].startBlock); + writeln('** addPartitions .', ord(partblk[partno].name[1])); + writeln('** addPartitions >', length(partblk[partno].name)); + writeln('** addPartitions ', partblk[partNo].name); } + part := partblk[partNo]; + deviceId := devid; + partitionId := partNo; + startSlot := 0; + freeSlot := 0; + dirCache := nil; + cachedBlock := -1; + cacheDirty := false; + openFilesCount := 0; + end; + + { if (PartDefault in flags) and (DefaultVolumeId = 0) then + DefaultVolumeId := volumeCount; } + + {writeln('added volume ', volumeCount);} + end; + end; +end; + +procedure readPartitions(devid: integer); +var blkNo:integer; + partblk:PartitionTableBlock; + isLast:boolean; + error:integer; +begin + blkNo := 0; + isLast := false; + error := 0; + + for blkNo := 0 to 7 do + begin + readpartblk(blkNo, partblk, error, devid); + if error = 0 then + addPartitions(devid, partblk, isLast) + else + (* TODO: some real error handling *) + writeln('Error reading partition block ', blkNo); + + if isLast or (error <> 0) then break; + end; +end; + +procedure readdevice(deviceId:integer;blockNo:integer;var buf:IOBlock; var error:integer); +begin + (* TODO: check for card change *) + readblock(blockNo, buf, error, deviceId); + { writeln('readblock ', blockNo); } +end; + +procedure writedevice(deviceId:integer;blockNo:integer;var buf:IOBlock; var error:integer); +begin + (* TODO: check for card change *) + writeblock(blockNo, buf, error, deviceId); + { writeln('writeblock ', blockNo); } +end; + +function getphysblockno(volumeid:integer; blockNo:integer):integer; +begin + (* TODO: check for valid volume id and blockNumber, how to return error? *) + getphysblockno := volumetable[volumeid].part.startBlock + blockNo; +end; + +(* read some consecutive blocks from a volume *) +procedure readvolumeblks(volumeid:integer; destbuf:^iobuffer; blkno:integer; blkCount: integer; var error:integer); +var deviceblk:integer; + deviceid:integer; + i:integer; +begin + deviceblk := getphysblockno(volumeid,blkno); (* TODO: check valid block number *) + deviceid := volumetable[volumeid].deviceid; + i := 0; + + { writeln('***** readvolumeblk ', blkno, ' ', blkCount, ' ', destbuf); } + while blkCount > 0 do + begin + readdevice(deviceid, deviceblk, destbuf^[i], error); (* read one block *) + (* TODO: should be able to read multiple blocks from the card *) + { writeln(' data: ', destbuf^[i][0]); } + blkCount := blkCount - 1; + deviceblk := deviceblk + 1; + i := i + 1; + end; +end; + +(* write some consecutive blocks onto a volume *) +procedure writevolumeblks(volumeid:integer; srcbuf:^iobuffer; blkno:integer; blkCount: integer; var error:integer); +var deviceblk:integer; + deviceid:integer; + i:integer; +begin + deviceblk := getphysblockno(volumeid,blkno); (* TODO: check valid block number *) + deviceid := volumetable[volumeid].deviceid; + i := 0; + while blkCount > 0 do + begin + writedevice(deviceid, deviceblk, srcbuf^[i], error); (* write one block *) + (* TODO: should be able to write multiple blocks to the card, maybe do an erase cmd before *) + blkCount := blkCount - 1; + deviceblk := deviceblk + 1; + i := i + 1; + end; +end; + +function findvolume(name:string):integer; +var volidx:integer; +begin + initDevices; + + findvolume := 0; + for volidx := 1 to volumeCount do + begin + if volumeTable[volidx].part.name = name then + begin + findvolume := volidx; + break; + end; + end; +end; + +procedure flushdircache(volumeid:integer;var error:integer); +begin + with volumeTable[volumeid] do + begin + if (dirCache <> nil) and (cachedBlock >= 0) and cacheDirty then + begin + { writeln('*** flushdircache'); } + writedirblk(getPhysBlockNo(volumeid, cachedBlock), dirCache^, error, deviceId); + cacheDirty := false; + end; + end; +end; + +procedure openvolumeid(volid:integer); +begin + with volumeTable[volid] do + begin + if dirCache = nil then + new(dirCache); + openFilesCount := openFilesCount + 1; + end; +end; + +procedure closevolumeid(volid:integer); +var error:integer; +begin + with volumeTable[volid] do + begin + openFilesCount := openFilesCount - 1; + if openFilesCount = 0 then + begin + flushdircache(volid, error); + cachedBlock := -1; + dispose(dirCache); + dirCache := nil; + + end; + end; +end; + +procedure loaddirblock(volumeid:integer;dirblkno:integer;var error:integer); +begin + with volumeTable[volumeid] do + begin + if cachedBlock <> dirblkno then + begin + flushdircache(volumeid, error); + { writeln(' loaddirblock dirBlkNo:', dirblkno, ' phys:', getPhysBlockNo(volumeid, dirblkno)); } + readdirblk(getPhysBlockNo(volumeid, dirblkno), dirCache^, error, deviceId); + cachedBlock := dirblkno; + end; + end; +end; + +(* read a specific directory slot from a volume *) +procedure getdirslot(volumeid:integer;slotNo:integer;var result:DirectorySlot;var error:integer); +var dirblkno:integer; + slotOffset:integer; +begin + error := 0; + + with volumeTable[volumeid] do + begin + dirblkno := slotNo div 8; + slotOffset := slotNo mod 8; + + (* writeln('get dirBlkNo:', dirblkno, ' slotOffset:', slotOffset); *) + + loaddirblock(volumeid, dirblkno, error); + result := dirCache^[slotOffset]; + end; +end; + +(* write a specific directory slot of a volume *) +procedure putdirslot(volumeid:integer;slotNo:integer;var dirslot:DirectorySlot;var error:integer); +var dirblkno:integer; + slotOffset:integer; +begin + with volumeTable[volumeid] do + begin + dirblkno := slotNo div 8; + slotOffset := slotNo mod 8; + + { writeln('put dirBlkNo:', dirblkno, ' slotOffset:', slotOffset); } + + loaddirblock(volumeid, dirblkno, error); + (* TODO: check for error *) + dirCache^[slotOffset] := dirslot; + cacheDirty := true; + end; +end; + +(* find a free directory slot, return the slot number *) +function finddirslot(volid:integer; var error:integer):integer; +var slotno:integer; + maxSlots:integer; + dirslot:DirectorySlot; + done:boolean; +begin + finddirslot := -1; + + with volumeTable[volid] do + begin + maxSlots := part.dirSize; + slotno := startSlot; + { writeln('** finddirslot startSlot ', slotno, ' maxSlots ', maxSlots); } + done := false; + repeat + getdirslot(volid, slotno, dirslot, error); + { writeln('** slot ', slotno, ' ', dirslot.name); } + if SlotFree in dirslot.flags then + begin + finddirslot := slotno; + done := true; + freeSlot := slotno; + { writeln('** free slot found at ', slotno); } + end + slotNo := slotNo + 1; + until done or (slotNo >= maxSlots) or (error <> 0); + end; +end; + + +(* read in the file buffer for the current seek position *) +procedure readbuf(var fil:file;var error:integer); +var blkno:integer; +begin + (* calculate block number from seek position and start block *) + (* fil.bufStart := fil.filpos and not 511; *) (* if we had arithmetic AND *) + fil.bufStart := fil.filpos - fil.filpos mod 512; + blkno := fil.bufStart div 512 + + fil.fileno * fil.extentBlocks; (* fileno is the directory slot number + which is equivalent to the start extent *) + (* read the number of blocks equivalent to the buffer size from the device *) + readvolumeblks(fil.volumeid, fil.buffer, blkno, fil.bufBlocks, error); + { writeln(' readbuf data: ', fil.buffer^[0][0]); } +end; + +procedure fileerror(var fil:file; error:integer); +begin + (* should check if there was an error already + and throw a runtime error in that case *) + fil.lastError := error; + fil.errorAck := false; +end; + +function IOResult(var fil:file):integer; +begin + IOResult := fil.lastError; + fil.errorAck := true; +end; + +function ErrorStr(err:integer):string; +begin + if err <= IOMaxErr then + ErrorStr := ioerrordesc[err] + else + ErrorStr := 'Invalid error code'; +end; + +(* TODO: should eof return false if the file + is in error state? *) +function eof(var fil:file):boolean; +begin + if fil.typ = IODiskFile then + eof := fil.filpos >= fil.size + else + eof := fil.ateof; +end; + +function eoln(var fil:file):boolean; +begin + eoln := eof(fil) or fil.ateoln; +end; + +(* read from filesystem. + destbuf is a opaque pointer to a number of words specified by len. + len is specified in bytes, and does not have to be a multiple of the word size. + (really? maybe two options: either len is 1 (scanning for string end), + or a multiple of the word size (reading in binary data)) + The compiler converts a passed aggregate object to the opaque pointer. + This pointer is then passed to the assembly routine copybuf *) +procedure readfs(var fil:file; destbuf:^IOBuffer; len:integer); +var bufleft, partial:integer; + destpos:integer; + blkno: integer; + error: integer; +begin + error := 0; + destpos := 0; + + (* check for read beyond end of file *) + if fil.filpos + len > fil.size then + len := fil.size - fil.filpos; + (* TODO: how to represent a short read? + set error to EOF? add a var parameter + which returns the number of bytes read? + *) + (* writeln('**** readfs ', len, ' at ', fil.filpos); *) + while (len > 0) and (error = 0) do + begin + if fil.bufpos < fil.bufsize then (* is something left in the buffer? *) + begin + bufleft := fil.bufsize - fil.bufpos; + (*writeln('**** readfs ++ ', bufleft); + writeln(' ** ', fil.buffer^[0][0]);*) + if len > bufleft then + partial := bufleft + else + partial := len; + copybuf(destbuf, destpos, fil.buffer, fil.bufpos, partial); + (*writeln(' *> ', destbuf^[0][0]);*) + len := len - partial; + fil.bufpos := fil.bufpos + partial; + fil.filpos := fil.filpos + partial; + destpos := destpos + partial; + end + else + begin + readbuf(fil, error); + fil.bufpos := 0; + end; + end; + + if error <> 0 then + fileerror(fil, error); +end; + +(* write back the file buffer *) +procedure flushfile(var fil:file); +var blkno:integer; + error:integer; +begin + blkno := fil.bufStart div 512 + + fil.fileno * fil.extentBlocks; + (* write buffer back to disk *) + writevolumeblks(fil.volumeid, fil.buffer, blkno, fil.bufBlocks, error); + if error <> 0 then + fileerror(fil, error); + fil.needsflush := false; +end; + +(* seek to a specific byte position in a file *) +(* a seek beyond the end of the file is an error, + except to the position one byte beyond. *) +procedure seek(var fil:file; position:integer); +var blkno:integer; + error:integer; +begin + checkerror(fil); + + if fil.typ = IOChannel then + fileerror(fil, IOSeekInvalid) + else + begin + if fil.needsflush then (* write back current buffer if necessary *) + flushfile(fil); + (* check for seek beyond end of file or append-only mode *) + if (position > fil.size) or (fil.mode = ModeAppend) then + fileerror(fil, IOSeekInvalid) + else + begin + fil.filpos := position; + fil.bufpos := position mod fil.bufsize; + (* if the new file position is outside current buffer, + read new buffer *) + if (position < fil.bufStart) or + (position >= fil.bufStart + fil.bufSize) then + begin + { writeln('***** seek readbuf ', position); } + readbuf(fil, error); + if error <> 0 then + fileerror(fil, error); + end; + end; + end; +end; + +function filepos(var fil:file):integer; +begin + if fil.typ = IOChannel then + filepos := 0 + else + filepos := fil.filpos; +end; + +function filesize(var fil:file):integer; +begin + if fil.typ = IOChannel then + filesize := -1 + else + filesize := fil.size; +end; + +(* allocate more extents for a file *) +procedure extendfile(var fil:file; newSize:integer); +var newExtents:integer; + entry:DirectorySlot; + endSlot:integer; + i:integer; + error:integer; +begin + if newSize > fil.size then + begin + newExtents := newSize div (fil.extentBlocks * 512) + 1; + { writeln('extendfile old extents:', fil.sizeExtents, ' new extents:', newExtents, ' extentBlocks:', fil.extentBlocks); } + if newExtents > fil.sizeExtents then + begin + (* we need to allocate one or more new extents *) + endSlot := fil.fileno + newExtents - 1; (* extent number starts at zero *) + (* start after the first extent of the file *) + for i := fil.fileno + fil.sizeExtents to endSlot do + begin + (* read in the directory slot *) + getdirslot(fil.volumeid, i, entry, error); + if not (SlotFree in entry.flags) then + begin + { writeln('extendfile IONoSpace'); } + (* if it is not free, we can't extend the file + and we return an error *) + fileerror(fil, IONoSpace); + break; + end + else + begin + { writeln('extendfile marked slot ', i); } + (* mark the slot as in use *) + entry.flags := entry.flags - [SlotFree,SlotEndScan] + [SlotExtent]; + (* write back the slot *) + putdirslot(fil.volumeid, i, entry, error); + if error <> 0 then + fileerror(fil, error); + end; + end; + (* read(dummy); *) + end; + + if fil.lastError = 0 then + begin + fil.size := newSize; + fil.sizeExtents := newExtents; + (* update directory here? *) + end; + end; +end; + +(* write to filesystem *) +(* srcbuf is used as a generic pointer to an array of words, len is the actual + length in bytes, and the length does not have to be word-aligned + The compiler converts any passed aggregate object into the pointer type. + The pointer is then passed opaquely to the assembly routine copybuf. *) +(* TODO: what about strings? a small assembly routine that gets a pointer + to the string and converts by skipping the string header and adding a length arg? *) +procedure writefs(var fil:file; srcbuf:^IOBuffer; len:integer); +var + bufleft:integer; + srcleft:integer; + srcpos:integer; + blkno:integer; + newpos:integer; + error:integer; +label errexit; + +begin + bufleft := fil.bufsize - fil.bufpos; + srcleft := len; + srcpos := 0; + error := 0; + + if fil.mode = ModeReadonly then + begin + fileerror(fil, IOReadOnly); + goto errexit; + end; + + newpos := fil.filpos + len; + if newpos > fil.size then + begin + extendfile(fil, newpos); + if fil.lastError <> 0 then goto errexit; + end; + + { if len = 1 then + writeln('writefs write char: ', srcbuf^[0][0]); } + + while (srcleft > 0) and (error = 0) do + begin + fil.changed := true; + fil.needsflush := true; + + { writeln('writefs bufpos:', fil.bufpos, ' srcleft:', srcleft, ' bufleft:', bufleft); } + (* will we cross a buffer boundary? *) + if srcleft > bufleft then + begin + { writeln('writefs part ', srcpos, ' -> ', fil.bufpos, ' ', bufleft); } + (* copy the part from the source that fits into the file buffer *) + copybuf(fil.buffer, fil.bufpos, srcbuf, srcpos, bufleft); + (* the bufffer is flushed below *) + + (* reset buffer position and advance pointer *) + fil.bufpos := 0; + fil.filpos := fil.filpos + bufleft; + srcleft := srcleft - bufleft; + srcpos := srcpos + bufleft; + bufleft := fil.bufsize; + end + else (* the data we want to write fits into the buffer *) + begin + { writeln('writefs ____ ', srcpos, ' -> ', fil.bufpos, ' ', srcleft); } + (* copy what is left of the source into buffer *) + copybuf(fil.buffer, fil.bufpos, srcbuf, srcpos, srcleft); + (* advance buffer position and file pointer *) + fil.bufpos := fil.bufpos + srcleft; + fil.filpos := fil.filpos + srcleft; + bufleft := bufleft - srcleft; + srcleft := 0; + end; + + (* if we moved out of the current iobuffer, read + in the new one *) + if fil.filpos >= fil.bufStart + fil.bufSize then + begin + { writeln('writefs flush at ', fil.filpos, ' ', fil.bufStart); } + flushfile(fil); + + (* Only read in new buffer + if the data left to write is not + larger than the buffer size. + In that case, the whole buffer would + be overwritten anyway. *) + if srcleft < fil.bufSize then + readbuf(fil, error) + else + fil.bufStart := fil.bufStart + fil.bufSize; + end; + + if error <> 0 then + fileerror(fil, error); + end; +errexit: +end; + +function findfile(volid:integer; var name:filenamestr; var dirslot:DirectorySlot;var error:integer):integer; +var slotno:integer; + maxSlots:integer; + done:boolean; + found:boolean; +begin + findfile := -1; + with volumeTable[volid] do + begin + maxSlots := part.dirSize; + slotno := startSlot; + { writeln('** findfile ', slotno); } + done := false; + found := false; + repeat + getdirslot(volid, slotno, dirslot, error); + { writeln('** slot ', slotno, ' flags: ', dirslot.flags, ' name:', dirslot.name, ' error:', error); } + if not (SlotDeleted in dirslot.flags) and (SlotFirst in dirslot.flags) + and (name = dirslot.name) then + begin + findfile := slotno; + done := true; + found := true; + { writeln('** found at slot ', slotno); } + end + if SlotEndScan in dirslot.flags then + done := true; + + slotNo := slotNo + 1; + until done or (slotNo >= maxSlots) or (error <> 0); + + if (error = 0) and (not found) then + error := IOFileNotFound; + end; +end; + +(* initialize a file record from a directory slot *) +procedure openfile(volid:integer; slotno:integer; var dirslot:DirectorySlot; var aFile:File; mode:filemode); +var extentSize:integer; +begin + extentSize := volumeTable[volid].part.extentSize; + + aFile.typ := IODiskFile; + aFile.mode := mode; + new(aFile.buffer); + aFile.bufpos := 0; + aFile.bufsize := DefaultBufSize; + aFile.needsflush := false; + aFile.changed := false; + aFile.lastError := 0; + aFile.errorAck := false; + aFile.volumeid := volid; + aFile.fileno := slotno; + aFile.filpos := 0; + aFile.bufStart := 1; + aFile.size := dirslot.sizeBytes; + aFile.sizeExtents := dirslot.sizeBytes div extentSize + 1; + aFile.bufBlocks := DefaultBufBlocks; + aFile.extentBlocks := extentSize div 512; + + seek(aFile,0); +end; + +procedure updatedirslot(var aFile:file); +var dirs: DirectorySlot; + error: integer; +begin + getdirslot(aFile.volumeid, aFile.fileno, dirs, error); + { writeln('updatedirslot 1 ', aFile.fileno, ' ', error); } + if error = 0 then + begin + dirs.sizeBytes := aFile.size; + dirs.modTime := GetCurTimestamp; + putdirslot(aFile.volumeid, aFile.fileno, dirs, error); + end; + { writeln('updatedirslot 2 ', aFile.fileno, ' ', error); } + fileerror(aFile, error); +end; + +procedure close(var aFile:file); +begin + if aFile.typ = IODiskFile then + begin + { writeln('close needsflush:', aFile.needsflush, ' changed:', aFile.changed, ' error:', aFile.lastError); } + if aFile.needsflush then + flushfile(aFile); + if aFile.lastError = 0 then + begin + fileerror(aFile, IOFileClosed); + { writeln('close f.buffer:', aFile.buffer); } + dispose(aFile.buffer); + aFile.buffer := nil; + + if aFile.changed then + updatedirslot(aFile); + + end; + + closevolumeid(aFile.volumeid); + end; +end; + +procedure deletefile(volid:integer; slotno:integer; var dirslot:DirectorySlot; var error:integer); +begin + dirslot.flags := dirslot.flags - [SlotFirst] + [SlotDeleted]; + putdirslot(volid, slotno, dirslot, error); +end; + +(* Create a new file. If slotno is not 0, it points to a directory + slot of an existing file with the same name, and dirslot is set. + In this case, the old file will be deleted and a new directory slot is + allocated. The new slot is returned in slotno and dirslot. + If overwrite is set to false, no file will be created and + error will be set to IOFileExists. *) +procedure createfile(volid:integer; name:filenamestr; overwrite:boolean; + var slotno:integer; var dirslot:DirectorySlot; var error:integer); +var generation:integer; + done:boolean; + oldslotno:integer; + olddirslot:DirectorySlot; + createTs:Timestamp; + nowTs:Timestamp; +begin + generation := 0; + oldslotno := findfile(volid, name, olddirslot, error); + + if (not overwrite) and (oldslotno > 0) then + begin + (* TODO: this is redundant, see open which + is the only point from where createfile + is called *) + error := IOFileExists; + slotno := -1; + end + else + begin + nowTs := GetCurTimestamp; + + if overwrite and (oldslotno > 0) then + begin + (* if we overwrite a file, increment + generation number and use the + old creation time *) + generation := olddirslot.generation + 1; + createTs := olddirslot.createTime; + end + else + createTs := nowTs; + + slotno := finddirslot(volid, error); + if slotno <= 0 then + error := IONoSpace + else + if (slotno > 0) and (error = 0) then + begin + getdirslot(volid, slotno, dirslot, error); + dirslot.name := name; + dirslot.flags := [SlotFirst]; + dirslot.sizeBytes := 0; + dirslot.generation := generation; + dirslot.owner := 0; + dirslot.modTime := nowTs; + dirslot.createTime := createTs; + putdirslot(volid, slotno, dirslot, error); + if overwrite and (oldslotno > 0) then + deletefile(volid, oldslotno, olddirslot, error); + end + end; +end; + +procedure initDevices; +begin + if cardchanged then + DevicesInitialized := false; + + (* we just handle one sdcard device here *) + if not DevicesInitialized then + begin + DefaultVolumeId := 0; + + initsdcard; + volumeCount := 0; + readPartitions(0); + DevicesInitialized := true; + + (* DefaultVolume may be set by the shell *) + if length(DefaultVolume) > 0 then + DefaultVolumeId := findvolume(DefaultVolume); + + (* If DefaultVolumeId is still not set, just use the + first volume. *) + if (DefaultVolumeId = 0) and (volumeCount > 0) then + DefaultVolumeId := 1; + end; +end; + +procedure readdirnext(volid:integer; var index:integer; var dirslot:DirectorySlot; var error:integer); +var lastSlot:integer; + found:boolean; +begin + lastSlot := volumeTable[volid].part.dirSize - 1; + found := false; + + repeat + getdirslot(volid, index, dirslot, error); + index := index + 1; + found := SlotFirst in dirslot.flags; + until found or (SlotEndScan in dirslot.flags) or + (index = lastSlot) or (error <> 0); + + if not found then + index := -1; +end; + +procedure readdirfirst(volid:integer; var index:integer; var dirslot:DirectorySlot; var error:integer); +begin + initDevices; + index := volumeTable[volid].startSlot; + readdirnext(volid, index, dirslot, error); +end; + +function charpos(searchChar:char; var s:string):integer; +var c:char; + p:integer; +begin + charpos := 0; + p := 1; + + for c in s do + begin + if c = searchChar then + begin + charpos := p; + break; + end; + p := p + 1; + end; +end; + +(* Open volume by name and search for a file. + Increases the open counter of the volume, + so you need to call closevolumeid() at some point later. +*) +procedure openvolpath(path:pathnamestr; var volid:integer; + var fname:filenamestr; + var slotno:integer; var dirs:DirectorySlot; var error:integer); +var i:integer; + separatorPos:integer; + volname:filenamestr; +begin + initDevices; + slotno := 0; + error := 0; + volid := 0; + + if path[1] = '#' then + begin + separatorPos := charpos(':', path); + if separatorPos > 0 then + begin + volname := copy(path, 2, separatorPos - 2); + fname := copy(path, separatorPos + 1, length(path) - separatorPos); + { writeln('openvolpath volname:', volname, ' fname:', fname, ' separatorPos:', separatorPos); } + volid := findvolume(volname); + end + end + else + begin + volid := DefaultVolumeId; + fname := path; + end; + + if volid > 0 then + begin + openvolumeid(volid); + slotno := findfile(volid, fname, dirs, error) + end + else + error := IOVolNotFound; + + (* writeln('openvolpath ', path, ' volid ', volid, ' slotno ', slotno, ' error ', error); *) +end; + +procedure rename(oldname:filenamestr; newname:filenamestr; var error:integer); +var olddirs:DirectorySlot; + newdirs:DirectorySlot; + volid:integer; + oldslotno:integer; + newslotno:integer; + fname:filenamestr; +begin + volid := 0; + + (* cannot specify a volume name in the new filenamestr specification, + or a channel name *) + if newname[1] in [ '#', '%' ] then + error := IOPathInvalid + else + begin + (* locate the old file *) + openvolpath(oldname, volid, fname, oldslotno, olddirs, error); + if error = 0 then + begin + { writeln('rename slot ', oldslotno, ' checking for ', newname); } + (* check if new filenamestr already exists *) + newslotno := findfile(volid, newname, newdirs, error); + if error = IOFileNotFound then + (* if new filename was not found, we can rename *) + begin + error := IONoError; + olddirs.name := newname; + putdirslot(volid, oldslotno, olddirs, error); + end + else + if error = 0 then + (* if new filename was found, we can not rename + and return an error *) + error := IOFileExists; + + (* otherwise we return the error set by findfile *) + end; + if volid > 0 then + closevolumeid(volid); + end; +end; + +procedure erase(name:pathnamestr; var error:integer); +var dirs:DirectorySlot; + volid:integer; + slotno:integer; + fname:filenamestr; +begin + error := 0; + + if name[1] = '%' then + error := IOPathInvalid + else + begin + (* locate the file *) + openvolpath(name, volid, fname, slotno, dirs, error); + { writeln('** erase slot ', slotno, ' e:', error); } + if error = 0 then + begin + if SlotReadonly in dirs.flags then + error := IOReadOnly + else + deletefile(volid, slotno, dirs, error); + end; + + if volid > 0 then + closevolumeid(volid); + end; +end; + +procedure writechannel(var f:file; aChar:char); +begin + conout(aChar); +end; + +procedure writechannelw(var f:file; word:integer); +begin + conoutw(word); +end; + +procedure echochannel(var f:file; aChar:char); +begin + if not f.noecho then + begin + if f.raw then + writechannel(f, aChar) + else + if (aChar <> #8) and (aChar <> #127) and (aChar <> #4) then + begin + writechannel(f,aChar); + if aChar = #13 then + writechannel(f, #10); + end; + end; +end; + +function readchannel(var f:file):char; +var aChar:char; +begin + if f.buflen > 0 then + begin + aChar := f.bufchar; + f.buflen := 0; + end + else + begin + aChar := conin(); + echochannel(f, aChar); + end; + + f.ateof := aChar = #4; (* set atEof flag if ^D entered *) + + if (f.nointr = false) and (aChar = #3) then + begin + fileerror(f, IOUserIntr); + checkerror(f) + end; + + readchannel := aChar; +end; + +function freadchar(var f:file):char; +var error:integer; +begin + if f.typ = IOChannel then + freadchar := readchannel(f) + else + freadchar := readfschar(f); + + f.ateoln := (freadchar = #13) or (freadchar = #10); +end; + +procedure fwritechar(aChar:char; var f:file); +begin + if f.typ = IOChannel then + writechannel(f, aChar) + else + writefschar(f, aChar); +end; + +procedure fwritestring(var aString:string; var f:file; w:integer); +var ch:char; + missing,i:integer; +begin + missing := w - length(aString); + if missing > 0 then + begin + for i := 1 to missing do + fwritechar(' ', f); + end; + + if f.typ = IOChannel then + begin + for ch in aString do + writechannel(f, ch) + end + else + begin + { writeln('fwritestring to file'); } + writefsstring(f, aString); + end; +end; + +procedure fwriteint(v:integer; var f:file; w:integer); +var rbuf:string[12]; +begin + (* use field width 0 for intstr because fwritestring can + handle any widths without needing a buffer *) + intstr(v, 0, rbuf); + fwritestring(rbuf, f, w); +end; + +procedure fwritereal(v:real; var f:file; w,d:integer); +var rbuf:string[48]; +begin + realstr(v, w, d, rbuf); + fwritestring(rbuf, f, w); +end; + +(* size must be multiple of word size (hardcoded to be 4) *) +procedure fwritewords(words:^IOBuffer; var f:file; size:integer); +begin + if f.typ = IODiskFile then + writefs(f, words, size) + else + writechanwords(f, words, size shr 2); +end; + +(* size must be multiple of word size (hardcoded to be 4) *) +procedure freadwords(words:^IOBuffer; var f:file; size:integer); +var w,count:integer; +begin + if f.typ = IODiskFile then + readfs(f, words, size) + else + readchanwords(f, words, size shr 2); +end; + +(* Pushes one character back onto an input stream. + For a channel, the next character read will be aChar. + + For a disk file, aChar is ignored and the file position + is just changed. + + It is not valid to push back a character if the seek position is 0. +*) + +procedure pushback(var aFile:file; aChar:char); +begin + if aFile.typ = IODiskFile then + seek(aFile, aFile.filpos - 1) + else + begin + aFile.bufchar := aChar; + aFile.buflen := 1; + end; +end; + +procedure openchannel(name:filenamestr; var f:file; mode:filemode; var error:integer); +begin + f.typ := IOChannel; + f.mode := mode; + f.buflen := 0; + f.ateof := false; + f.noecho := false; + f.raw := false; + f.nointr := false; + + if name = '%CON' then + f.channelid := 0 + else + if name = '%KBD' then + begin + f.channelid := 0; + f.noecho := true; + f.raw := true; + end + else + if name = '%RAW' then + begin + f.channelid := 0; + f.noecho := true; + f.raw := true; + f.nointr := true; + end + else + error := IOFileNotFound; +end; + +procedure open(var f:file; name:pathnamestr; mode: filemode); +var error:integer; + dirs:DirectorySlot; + slotno:integer; + volid:integer; + exclusive:boolean; + overwrite: boolean; + createmissing: boolean; + fname:filenamestr; +begin + if name[1] = '%' then + openchannel(name, f, mode, error) + else + begin + volid := 0; + + exclusive := (mode = ModeCreate); + overwrite := (mode = ModeOverwrite); + createmissing := (mode = ModeCreate) or (mode = ModeOverwrite) or (mode = ModeAppend); + + openvolpath(name, volid, fname, slotno, dirs, error); + + if (error = 0) and exclusive then + begin + fileerror(f, IOFileExists); + error := IOFileExists; + end; + + if ((error = IOFileNotFound) and createmissing) or + ((error = 0) and overwrite) then + (* TODO: overwrite flag is redundant, if we get here, + we always want the file overwritten *) + createfile(volid, fname, overwrite, slotno, dirs, error); + + if error = 0 then + begin + openfile(volid, slotno, dirs, f, mode); + + if mode = ModeAppend then + seek(f, f.size); + end; + + if (error <> 0) and (volid > 0) then + closevolumeid(volid); + + if error <> 0 then + fileerror(f, error); + end; +end; + +procedure noecho(var f:file;noecho:boolean;var old:boolean); +begin + if f.typ <> IOChannel then + fileerror(f, IOInvalidOp) + else + begin + old := f.noecho; + f.noecho := noecho; + end; +end; + +(* + implementation of Xorshift algorithm by George Marsaglia, + see: Marsaglia, George (July 2003). + "Xorshift RNGs". Journal of Statistical Software. 8 (14). + doi:10.18637/jss.v008.i14 +*) + +function random:integer; +var x:integer; +begin + x := random_state; + x := x xor (x shl 13); + x := x xor (x shr 17); + x := x xor (x shl 5); + + random_state := x; + if x < 0 then x := abs(x); + random := x; +end; + +procedure randomize; +begin + random_state := getticks() xor $AFFECAFE; +end; + +(* there is already an assembly routine upcase + in lib.s, so we do not need this one. *) +{ +function upcase(aChar:char):char; +begin + (* use cascaded IF to make it a teeny bit faster + than using AND *) + if ord(aChar) >= ord('a') then + if ord(aChar) <= ord('z') then + upcase := chr(ord(aChar) - 32) + else + else + upcase := aChar; +end; +} + +{$I 'stdterm.inc'} (* terminal handling procedures *) + +(* Execute a program from a file. + If there is an error accessing the file, this procedure + returns and sets the error variable accordingly. + Otherwise, program execution is turned over to + the new program and PExec does not return. + + The arguments for the new program is passed with + the args array. argCount specifies how many arguments + are actually used. If argCount is invalid (negative or + larger than the maximum (PArgLast + 1), PExec returns + with the error code set to IOInvalidOp. + *) + +procedure PExec(prgfile:pathnamestr; var args:PArgVec; argCount:integer;var error:integer); +var volid:integer; + fname:filenamestr; + dirslot:DirectorySlot; + slotno:integer; + i:integer; + startblock:integer; + physblock:integer; + devId:integer; +begin + if (argCount >= PArgMax) or (argCount < 0) then + error := IOInvalidOp + else + begin + openvolpath(prgfile, volid, fname, slotno, dirslot, error); + if error = 0 then + begin + with VolumeTable[volid] do + begin + (* get the physical device id from the volume table *) + devId := deviceId; + (* calculate start block of the file + relative to volume start *) + startblock := slotno * part.extentSize div 512; + end; + + (* get physical block number *) + physblock := getPhysBlockNo(volid, startblock); + closevolumeid(volid); + + (* set external Pargs array, clear the array elements which are + not used *) + PArgs[0] := prgfile; + for i := 1 to argCount do + PArgs[i] := args[i-1]; + for i := argCount + 1 to PArgMax do + PArgs[i] := ''; + PArgCount := argCount; + + (* this will overwrite the current program *) + coreload(devId, physblock, dirslot.sizeBytes); + end; + end; +end; + +procedure PExec2(prgfile:pathnamestr; arg1:string; var error:integer); +var args:PArgVec; +begin + args[0] := arg1; + PExec(prgfile, args, 1, error); +end; + +procedure PExec3(prgfile:pathnamestr; arg1, arg2:string; var error:integer); +var args:PArgVec; +begin + args[0] := arg1; + args[1] := arg2; + PExec(prgfile, args, 2, error); +end; + +function ParamStr(i:integer):string; +begin + if (i < 0 ) or (i > PArgMax) then + ParamStr := '' + else + ParamStr := PArgs[i]; +end; + +function ParamCount():integer; +begin + ParamCount := PArgCount; +end; + +procedure SetShellCmd(cmd:string[40]; arg:integer); +begin + ShellCmd := cmd; + ShellArg := arg; +end; + +PROCEDURE delay(ms:INTEGER); +VAR count:INTEGER; +BEGIN + + count := ms; + WHILE count > 0 DO + BEGIN + WAIT1MSEC; + count := count - 1; + END; +END; + +end. diff --git a/lib/stdterm.inc b/lib/stdterm.inc new file mode 100644 index 0000000..f2600d4 --- /dev/null +++ b/lib/stdterm.inc @@ -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; diff --git a/pcomp/.vscode/tasks.json b/pcomp/.vscode/tasks.json new file mode 100644 index 0000000..58a8ceb --- /dev/null +++ b/pcomp/.vscode/tasks.json @@ -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 + } + } + ] +} diff --git a/pcomp/emit.pas b/pcomp/emit.pas new file mode 100644 index 0000000..ed9fa33 --- /dev/null +++ b/pcomp/emit.pas @@ -0,0 +1,1620 @@ +(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *) +procedure emitOperator(op: string); forward; +procedure emitLoadIndirect; forward; +procedure emitCall(name:string); forward; +procedure emitCallRaw(name:string); forward; +procedure emitLabelRaw(name:IdentString); forward; +procedure emitInc(amount: integer); forward; +procedure emitDec(amount: integer); forward; +procedure emitLoadConstantInt(i: integer); forward; +procedure emitLoadNegConstInt(i: integer); forward; + +procedure rewindStringList(var list:StringList); forward; +function nextStringListItem(var list:StringList; var returnStr: IdentString): boolean; + forward; + +procedure cpuAllocStackframe(aProc:ProcRef); +begin + if aProc^.isNested then + begin + if aProc^.vars.offset <> 0 then + errorExit2('internal error in cpuAllocStackFrame for', aProc^.name ); + + (* allocate space for the outer frame pointer and old BP *) + aProc^.vars.offset := aProc^.vars.offset + (wordSize*2); + aProc^.parameters.offset := aProc^.parameters.offset + (wordSize*2); + end; +end; + +procedure countIns(amount: integer); +begin + insCount := insCount + amount; +end; + +procedure CPoolIfHighMark(jumpOver:boolean); forward; + +procedure emitIns(ins: string); +begin + writeln(outfile, #9, ins); + countIns(1); + CPoolIfHighMark(true); +end; + +function getLocalLabel(prefix:IdentString;no:integer):IdentString; +var buf: string[12]; +begin + str(no,buf); + getLocalLabel := prefix + buf + globalSuffix; +end; + +procedure emitLocalLabel(prefix:IdentString;no:integer); +begin + writeln(outfile, prefix,no,globalSuffix,':'); +end; + +procedure emitInsLabel(prefix:IdentString;no:integer); +begin + writeln(outfile, #9, prefix,no,globalSuffix); +end; + + +procedure emitCpool(jumpOver:boolean); +begin + insCount := 0; + if jumpOver then emitIns('.CPOOLNOP') else emitIns('.CPOOL'); +end; + +procedure CPoolIfLowMark(jumpOver:boolean); +begin + if insCount > lowCpoolMark then emitCpool(jumpOver); +end; + +procedure CPoolIfHighMark(jumpOver:boolean); +begin + if insCount > highCpoolMark then emitCpool(jumpOver); +end; + +procedure emitIns2(ins, op: string); +begin + writeln(outfile, #9, ins, ' ', op); + countIns(1); +end; + +procedure emitIns2Int(ins: string; op: integer); +begin + writeln(outfile, #9, ins, ' ', op); + countIns(1); +end; + +procedure emitPrologue; +begin + writeln(outfile, #9, '.ORG ', startAddress); + emitIns2('BRANCH', '@+16'); + emitIns2('BRANCH', '@+$AFE'); + emitLabelRaw('_HEAP_SZ_PTR'); + emitIns2Int('.WORD', defaultHeapSize); + emitLabelRaw('_STACK_SZ_PTR'); + emitIns2Int('.WORD', defaultStackSize); + emitIns2Int('.WORD', 0); + emitIns2('LOADCP','_END'); (* end of program is start of heap *) + emitIns2('LOADCP', '_MEM_INIT'); (* MEM_INIT initializes heap and sets FP/RP *) + (* since RP is not initialized yet, we cannot use CALL + and MEM_INIT jumps to _MAIN after it is done *) + emitIns('JUMP'); +end; + +function bytes2words(size:integer):integer; +begin + bytes2words := (size + (wordSize-1)) div wordSize +end; + +procedure emitGlobalVars; +var v: SymblRef; + wordsCount: integer; +begin + v := mainProcedure^.vars.first; + + while v <> nil do + begin + if not v^.isExternal then + begin + wordsCount := bytes2words(v^.size); + if v^.symType.baseType in [ ArrayType, RecordType ] then + begin + (* if an array has initial values, it is handled by + emitArrayConsts *) + if not v^.hasInitialValue then + writeln(outfile, v^.name, ':', #9, '.BLOCK ', wordsCount) + end + else if v^.symType.baseType = StringType then + begin + (* if a global string variable has an initial value, it + is handled by emitConstStrs *) + if not v^.hasInitialValue then + begin + writeln(outfile, v^.name, ':', #9, '.WORD 0'); + emitIns2Int('.WORD', v^.symType.stringLength); + emitIns2Int('.BLOCK', wordsCount - 2); + end + end + else + (* integer, real, boolean, char *) + writeln(outfile, v^.name, ':', #9, '.WORD ', v^.initialValue); + end; + v := v^.next; + end; +end; + +procedure emitString(var s:KeywordString; maxLength:integer); +var pad:integer; + c:char; + inQuotes:boolean; + first:boolean; + +procedure writeComma; +begin + if (not inQuotes) and (not first) then + write(outfile, ','); + first := false; +end; + +procedure startQuotes; +begin + if not inQuotes then + begin + writeComma; + write(outfile,'"'); + inQuotes := true; + end; +end; + +procedure endQuotes; +begin + if inQuotes then + begin + write(outfile,'"'); + inQuotes := false; + end; +end; + +procedure writeAsString; +begin + startQuotes; + write(outfile,c); +end; + +procedure writeAsNum; +begin + endQuotes; + writeComma; + write(outfile, ord(c)); +end; + +begin + inQuotes := false; + first := true; + writeln(outfile,#9,'.WORD ', length(s), ',', maxLength); + if length(s) > 0 then + begin + write(outfile,#9,'.BYTE '); + for c in s do + (* handle " inside strings *) + if c = '"' then + begin + startQuotes; + write(outfile,'""') + end + else + (* handle non-printable characters *) + if ord(c) < ord(' ') then + writeAsNum + else + writeAsString; + endQuotes; + writeln(outfile); + end; + if maxLength <> 0 then + begin + pad := bytes2words(maxLength) - bytes2words(length(s)); + if pad > 0 then + writeln(outfile,#9, '.BLOCK ', pad); + end; +end; + +procedure emitConstStrs; +var c: ConstStrRef; +begin + c := firstConstStr; + while c <> nil do + begin + if c^.extraLabel <> nil then + writeln(outfile, c^.extraLabel^,':'); + (* TODO: quote special characters *) + emitLocalLabel('_C_S_', c^.no); + emitString(c^.value, c^.length); + c := c^.next; + end; +end; + +procedure emitArrayConsts; +var current: ArrayConstRef; + elem: ^OpaqueDataElement; + count: integer; +begin + current := firstArrayConst; + while current <> nil do + begin + if current^.extraLabel <> nil then + writeln(outfile, current^.extraLabel^, ':'); + emitLocalLabel('_C_A_', current^.id); + + elem := current^.firstElement; + count := 0; (* counts the items in a single .WORD directive *) + while elem <> nil do + begin + if elem^.isStringValue then + begin + writeln(outfile); + count := -1; (* make count zero in next iteration *) + emitString(elem^.strValue^, elem^.maxLength); + end + else + if count = 0 then + begin + writeln(outfile); + write(outfile,#9,'.WORD ', elem^.intValue) + end + else + write(outfile,',', elem^.intValue); + count := (count + 1) and 7; + elem := elem^.next; + end; + writeln(outfile); + current := current^.next; + end; +end; + +procedure emitInclude(s:string); +begin + writeln(outfile, '%include "',s,'"'); + emitIns('.CPOOL'); +end; + +procedure emitUnitEpilogue; +begin + emitIns('.CPOOL'); + emitGlobalVars; + emitConstStrs; + emitArrayConsts; +end; + +procedure emitEpilogue; +var unitName:IdentString; +begin + if useStandalone then + emitIns2Int('LOADC', 0) + else + emitIns2('LOADCP', 'PTERM'); + emitIns('JUMP'); + + emitIns('.CPOOL'); + emitGlobalVars; + emitConstStrs; + emitArrayConsts; + + if useStandalone then + emitInclude('corelib.s') + else + emitInclude('coreloader.lsym'); + + emitInclude('float32.lib'); + emitInclude('runtime.lib'); + emitInclude('stdlib.lib'); + + rewindStringList(usedUnits); + while nextStringListItem(usedUnits, unitName) do + emitInclude(unitName + UnitSuffix2); + + emitLabelRaw('_END'); +end; + +procedure emitMainStart; +begin + writeln(outfile,'_MAIN:'); +end; + +procedure emitNewSymbol(scope: SymbolScope; var name: string; offset: integer); +begin + (* if scope = LocalSymbol then writeln(outfile, #9, '.EQU ', name, ' ', offset); *) +end; + +procedure emitDup; +begin + emitIns('DUP'); +end; + +(* call checkerror from stdlib, file ptr is already + on stack and needs to stay on stack *) +procedure emitCheckError; +begin + emitDup; + emitCall('CHECKERROR'); +end; + +procedure emitDefaultOutput; +begin + emitIns2('LOADCP', 'OUTPUT'); + emitCheckError; + emitIns('SWAP'); +end; + +procedure emitWriteFileArg; +begin + emitIns('OVER'); +end; + +procedure emitWrite(typeTag: TypeTagString); +begin + emitCall('FWRITE' + typeTag); +end; + +procedure emitWriteNewline; +begin + emitIns2('LOADCP','NEWLINESTR'); + emitIns('OVER'); + emitLoadConstantInt(0); + emitCall('FWRITESTRING'); +end; + +procedure emitDefaultNewline; +begin + emitIns2('LOADCP','NEWLINESTR'); + emitIns2('LOADCP', 'OUTPUT'); + emitLoadConstantInt(0); + emitCall('FWRITESTRING'); +end; + +procedure emitWriteEnd; +begin + emitIns('DROP'); +end; + +procedure emitWriteWords(size:integer); +begin + emitLoadConstantInt(size); + emitCall('FWRITEWORDS'); +end; + +procedure emitDefaultInput; +begin + emitIns2('LOADCP', 'INPUT'); + emitCheckError; + emitIns('SWAP'); +end; + +procedure emitReadFileArg; +begin + emitIns('OVER'); +end; + +procedure emitRead(typeTag: TypeTagString); +begin + emitCall('FREAD' + typeTag); +end; + +procedure emitReadWords(size:integer); +begin + emitLoadConstantInt(size); + emitCall('FREADWORDS'); +end; + +procedure emitReadNewline; +begin + emitCall('SKIPEOLN'); +end; + +procedure emitReadDefaultNewline; +begin + emitIns2('LOADCP', 'INPUT'); + emitReadNewline; +end; + +procedure emitReadEnd; +begin + emitIns('DROP'); +end; + +procedure emitLoadConstant(c: string); +begin + emitIns2('LOADC', c); +end; + +procedure emitLoadConstantInt(i: integer); +var s: string[32]; + rest:integer; +begin + if i < 0 then + emitLoadNegConstInt(i) + else + begin + str(i,s); + if i > MaxShortOffset then + begin + rest := i - MaxShortOffset; + if rest <= MaxTinyOffset then + begin + emitLoadConstantInt(MaxShortOffset); + emitInc(rest); (* a LOADC + INC is shorter that a LOADCP *) + end + else + emitIns2('LOADCP', s); + end + else + emitLoadConstant(s); + end; +end; + +procedure emitLoadNegConstInt(i: integer); +var s: string[32]; + rest:integer; +begin + if i > 0 then + errorExit2('internal error in emitLoadNegConstInt', '') + else + begin + str(i,s); + if i < -MaxShortOffset - 1 then + begin + rest := i + MaxShortOffset + 1; (* max negative short number is -4096 *) + if abs(rest) <= MaxTinyOffset then + begin + emitLoadNegConstInt(-(MaxShortOffset-1)); + emitDec(rest); (* a LOADC + INC is shorter that a LOADCP *) + end + else + emitIns2('LOADCP', s); + end + else + emitLoadConstant(s); + end; +end; + +procedure emitLoadConstantReal(r: real); +begin + emitLoadConstantInt(encodeFloat32(r)); +end; + +procedure emitLoadOffset(sym: SymblRef); +begin + writeln(outfile,#9, 'LOADC ', sym^.offset); + countIns(1); +end; + +procedure emitConstBoolean(b: boolean); +begin + if b then + emitLoadConstant('1') + else + emitLoadConstant('0'); +end; + +procedure emitSwap; +begin + emitIns('SWAP'); +end; + +function isShortLoadStore(var loc: MemLocation):boolean; +begin + isShortLoadStore := (loc.memLoc = LocalMem) and (loc.offset <= MaxUShortOffset); +end; + +procedure emitLoadLocalAddr(var name: IdentString; offset: integer); +begin + writeln(outfile,#9,' ; ', name); + emitIns2('LOADREG', 'FP'); + emitInc(offset); +end; + +procedure emitStoreLocal(offset:integer; var name: IdentString); +begin + if offset <= MaxUShortOffset then + begin + writeln(outfile,#9, 'STORE ', offset, ' ; ', name); + countIns(1); + end + else + begin + (* if it is not a short store, the address is already on the stack *) + emitIns('STOREI'); + emitIns('DROP'); + end +end; + +procedure emitStoreNested(offset:integer; distance: integer; var name: IdentString); +begin + if offset <= MaxUShortOffset then + begin + if distance = 1 then + begin + writeln(outfile,#9, 'STORE.B ', offset, ' ; ', name); + countIns(1); + end + else + begin + emitIns('STOREI'); + emitIns('DROP'); + end; + end + else + begin + (* if it is not a short store, the address is already on the stack *) + emitIns('STOREI'); + emitIns('DROP'); + end +end; + +procedure emitLoadNestedAddr(var name: IdentString; distance, offset: integer); +var i:integer; +begin + writeln(outfile,#9,' ; ', name); + if distance = 1 then + emitIns2('LOADREG', 'BP') + else + begin + emitIns2Int('LOAD.B', 0); + if distance > 2 then + begin + for i := 3 to distance do + emitIns('LOADI'); + end; + end; + emitInc(offset); +end; + +procedure emitStoreArg(sym: SymblRef); +begin + emitStoreLocal(sym^.offset, sym^.name); +end; + +function isLocalIndirect(var loc:MemLocation):boolean; +begin + isLocalIndirect := loc.offset > MaxUShortOffset; +end; + +(* place address of a local variable on stack for accessing it later. + this only emits code if the offset is greater than MaxUShortOffset. + otherwise, for accessing the variable LOAD or STORE is used and + no address on the stack is needed. *) +procedure emitLocalMemLoc(var loc:MemLocation); +begin + if isLocalIndirect(loc) then + emitLoadLocalAddr(loc.name, loc.offset); +end; + +function isNestedIndirect(var loc:MemLocation):boolean; +begin + isNestedIndirect := (loc.offset > MaxUShortOffset) or (loc.scopeDistance > 1); +end; + +(* Place address of a nested variable on stack for accessing it later. + This only emits code if the offset is greater than MaxUShortOffset, + or if the variable is from a distant outer scope (distance > 1). + Otherwise, for accessing the variable LOAD or STORE is used and + no address on the stack is needed. *) +procedure emitNestedMemLoc(var loc:MemLocation); +begin + if isNestedIndirect(loc) then + emitLoadNestedAddr(loc.name, loc.scopeDistance, loc.offset); +end; + +procedure emitLoadGlobalAddr(var name: IdentString; offset: integer); +begin + if offset = 0 then + writeln(outfile,#9, 'LOADCP ', name, ' ; ', name) + else + (* using the LOADCP constant with offset syntax *) + writeln(outfile,#9, 'LOADCP ', name, ',', offset, ' ; ', name); + countIns(1); +end; + +procedure emitLoadTempAddr(var name: IdentString; offset: integer); +begin + if offset <= 0 then + errorExit2('internal error: invalid temporary offset', name) + else + begin + emitIns2('LOADREG', 'FP'); + emitDec(offset); + end; +end; + +procedure emitWithStmntMemLoc(var loc:MemLocation; withSlot: integer); +var offset: integer; +begin + offset := withStmntStack[withSlot].tempLoc.offset; + emitLoadTempAddr(loc.name, offset); + emitIns('LOADI'); + emitInc(loc.offset); +end; + +procedure emitLoadLocal(offset: integer; var name: IdentString); +begin + if offset <= MaxUShortOffset then + begin + writeln(outfile,#9, 'LOAD ', offset, ' ; ', name); + countIns(1); + end + else + begin + (* if it is not a short load, the address is already on stack *) + emitIns('LOADI'); + end; +end; + +procedure emitLoadNested(offset: integer; distance:integer; var name: IdentString); +begin + if offset <= MaxUShortOffset then + begin + if distance = 1 then + begin + writeln(outfile,#9, 'LOAD.B ', offset, ' ; ', name); + countIns(1); + end + else + begin + emitIns('LOADI'); + end; + end + else + begin + (* if it is not a short load, the address is already on stack *) + emitIns('LOADI'); + end; +end; + +procedure emitShiftLeft(count: Integer); +var d: Integer; +begin + while count > 0 do + begin + if count >= 8 then + begin + emitIns('BROT'); + emitIns2('LOADC', '-$100'); (* $FFFFFF00 *) + emitIns('AND'); + d := 8; + end + else + if count >= 2 then + begin + emitIns2('SHL','2'); + d := 2; + end + else + begin + emitIns('SHL'); + d := 1; + end; + count := count - d; + end; +end; + +(* + try to emit code for quickly multiplying + numbers by shifting, used for array indices. + uses naive heuristics to convert powers of two + to shifts, otherwise uses the multiply routine. +*) +procedure emitFastMul(fac: integer); +begin + if fac = 1024 then emitShiftLeft(10) + else if fac = 512 then emitShiftLeft(9) + else if fac = 256 then emitShiftLeft(8) + else if fac = 128 then emitShiftLeft(7) + else if fac = 64 then emitShiftLeft(6) + else if fac = 32 then emitShiftLeft(5) + else if fac = 16 then emitShiftLeft(4) + else if fac = 8 then emitShiftLeft(3) + else if fac = 4 then emitShiftLeft(2) + else + begin + emitLoadConstantInt(fac); + emitOperator('MULU'); + end; +end; + +(* emit code to calculate the address of an array element. + the address and the index number are already on stack. + also emits code for a bounds check, so we must know + the array type.*) +procedure emitIndexToAddr(var symType: TypeSpec); +begin + if symType.arrayStart <> 0 then + (* adjust index to base 0 *) + emitDec(symType.arrayStart); + emitIns('DUP'); + emitLoadConstantInt(symType.arrayLength); + emitCallRaw('_BOUNDSCHECK'); + emitFastMul(symtype.elementType^.size); + emitIns('ADD'); +end; + +(* Emit code to calculate the byte address of an indexed string + (i.e. char at a specific position in the string). + The address and the index value are already on stack. + Does a bounds check. + Leaves the byte address on stack. *) +procedure emitStringIndexToAddr; +begin + emitCallRaw('_INDEXSTRING'); +end; + +procedure emitSubrangeCheckRaw(min,max:integer); +begin + emitLoadConstantInt(min); + emitLoadConstantInt(max); + emitCall('_RANGECHECK'); +end; + +procedure emitSubrangeCheck(min,max:integer); +begin + emitDup; (* duplicate the value that is being checked *) + emitSubrangeCheckRaw(min,max); +end; + +procedure emitEnumCheck(max:integer); +begin + emitDup; (* duplicate the value that is being checked *) + emitLoadConstantInt(max); + emitCall('_ENUMCHECK'); +end; + +procedure emitLoadStringChar; +begin + emitIns('LOADI.S1.X2Y'); + emitIns('BSEL'); +end; + +procedure emitSetStringChar; +begin + emitCallRaw('_SETSTRINGCHAR'); +end; + +procedure emitSetStringLength; +begin + emitCallRaw('_SETSTRINGLENGTH'); +end; + +procedure emitLoadIndirect; +begin + emitIns('LOADI'); +end; + +procedure emitStoreIndirect; +begin + emitIns('STOREI'); + emitIns('DROP'); +end; + +procedure emitFpAdjust(offset: integer); +begin + if abs(offset) > 0 then + begin + if abs(offset) > MaxShorterOffset then + begin + emitIns2('LOADREG', 'FP'); + if offset < 0 then + begin + emitLoadConstantInt(-offset); + emitIns('SUB'); + end + else + begin + emitLoadConstantInt(offset); + emitIns('ADD'); + end; + emitIns2('STOREREG', 'FP'); + end + else + emitIns2Int('FPADJ', offset); + end; +end; + +procedure emitCallRaw(name:string); +begin + emitIns2('LOADCP', name); + emitIns('CALL'); +end; + +procedure emitCall(name:string); +var tempsSize:integer; +begin + tempsSize := curProcedure^.tempsSize; + emitFpAdjust(-tempsSize); + emitIns2('LOADCP', name); + emitIns('CALL'); + emitFpAdjust(tempsSize); +end; + +procedure emitCopy(bytes: integer); +begin + emitLoadConstantInt(bytes div wordSize); + emitCall('_COPYWORDS'); +end; + +procedure clearLocalVar(sym:SymblRef); +begin + emitLoadLocalAddr(sym^.name, sym^.offset); + emitLoadConstantInt(sym^.size); + emitCallRaw('_CLEARMEM'); +end; + +procedure emitClearAlloc(typePtr:TypeSpecPtr); +begin + emitDup; + emitLoadConstantInt(typePtr^.size); + emitCallRaw('_CLEARMEM'); +end; + +procedure emitCheckAlloc; +begin + (* TODO: change back to emitCallRaw when + _CHECK_ALLOC does not use the program stack anymore + (that is, if it does not call _CHECK_CHUNK )*) + emitCall('_CHECK_ALLOC'); +end; + +procedure emitMemAlloc; +begin + emitCall('_MEM_ALLOC'); +end; + +procedure emitMemFree; +begin + emitCall('_MEM_FREE'); +end; + +(* requires char value and pointer to string buf already on stack, + leaves the string ptr *) +procedure emitConvCharToString; +begin + (* we need to leave the buffer addr on stack *) + emitSwap; + emitIns('OVER'); + (* after this, we have [ bufaddr, char, bufaddr ] on stack *) + emitCallRaw('_CHARTOSTRING'); +end; + +(* requires a string pointer on the stack, leaves a char value*) +procedure emitConvStringToChar; +begin + emitCallRaw('_STRINGTOCHAR'); +end; + +procedure emitInitTempString(var name: IdentString; offset, length: integer); +begin + emitLoadConstantInt(length); + emitLoadTempAddr(name, offset); + emitCallRaw('_INITSTRINGF'); +end; + +procedure emitForceInitString(var name: IdentString; offset, length: integer); +begin + emitLoadConstantInt(length); + emitLoadLocalAddr(name, offset); + emitCallRaw('_INITSTRINGF'); +end; + +procedure emitInitString(var name: IdentString; offset, length: integer); +begin + emitLoadConstantInt(length); + emitLoadLocalAddr(name, offset); + emitCallRaw('_INITSTRING'); +end; + +(* variant of emitInitString where the address is already on the stack *) +procedure emitInitStringShort(length: integer); +begin + emitLoadConstantInt(length); + emitIns('OVER'); + emitCall('_INITSTRING'); +end; + +(* variant of emitInitString where the address is already in next-to-top *) +(* which is only used for read/readln *) +procedure emitInitStringSwapped(length: integer); +begin + emitIns('OVER'); + emitLoadConstantInt(length); + emitSwap; + emitCall('_INITSTRING'); +end; + +procedure emitInitStringFrom(length: integer); +begin + emitLoadConstantInt(length); + emitCall('_INITSTRINGFROM'); +end; + +(* on the stack: [ max string length ] *) +procedure emitStringAlloc; +begin + emitCall('_STRING_ALLOC'); (* [ addr ]*) +end; + +procedure emitCopyString; +begin + emitCall('_COPYSTRING'); +end; + +procedure emitAppendString; +begin + emitCall('_APPENDSTRING'); +end; + +procedure emitLabelRaw(name:IdentString); +begin + writeln(outfile, name,':'); +end; + +procedure emitLabel(aLabl: LablRef); +begin + writeln(outfile, '_L',aLabl^.id,aLabl^.name, globalSuffix, ':'); +end; + +procedure emitLabelJump(aLabl: LablRef); +begin + (* use .LBRANCH directive instead of BRANCH so the assembler + can use the JUMP instruction if the offset is too large for BRANCH *) + writeln(outfile,#9, '.LBRANCH', ' ', '_L',aLabl^.id,aLabl^.name, globalSuffix); + countIns(5); + CPoolIfLowMark(false); +end; + +(* TODO: make this useful for normal and nested procedures, + and remove the "if aProc^.isNested then getProcedureLabel" stuff *) +procedure getProcedureLabel(aProc:ProcRef;var dest:IdentString); +var numberStr:string[8]; +begin + if aProc^.isNested then + begin + str(aProc^.id, numberStr); + dest := '_NST' + globalSuffix + numberStr + aProc^.name; + end + else + dest := aProc^.name; +end; + +function getProcFsLabel(aProc:ProcRef):IdentString; +begin + getProcFsLabel := aProc^.name + '_FS_'; +end; + +function getExitLabel(aProc:ProcRef):IdentString; +begin + getProcedureLabel(aProc, getExitLabel); + getExitLabel := getExitLabel + '_XT'; +end; + +procedure emitExitLabel(aProc:ProcRef); +begin + emitLabelRaw(getExitLabel(aProc)); +end; + +procedure emitProcedurePrologue(aProc:ProcRef); + var procLabel: IdentString; +begin + getProcedureLabel(aProc, procLabel); + emitLabelRaw(procLabel); + + emitFpAdjust(-aProc^.vars.offset); + + if aProc^.isNested then + begin + (* store old BP at offset 4 and + pointer to outer frame at offset 0 *) + emitIns2('LOADREG','BP'); + emitIns2('STORE','4'); + emitDup; + emitIns2('STOREREG', 'BP'); + emitIns2('STORE','0'); + end; +end; + +procedure emitProcedureEpilogue(aProc:ProcRef); +begin + if aProc^.isNested then + begin + (* restore old BP when exiting a nested procedure *) + emitIns2('LOAD','4'); + emitIns2('STOREREG','BP'); + end; + + emitFpAdjust(aProc^.vars.offset); + emitIns('RET'); + CPoolIfLowMark(false); +end; + +procedure emitExit(aProc:ProcRef); +var i:integer; +begin + (* clean up estack *) + for i := 1 to aProc^.estackCleanup do + emitIns('DROP'); + emitIns2('.LBRANCH', getExitLabel(aProc)); +end; + +(* Call a procedure. + the FP register must be adjusted before and after to + account for temporaries used by the caller. + When calling from a nested procedure, we need to restore + BP register after a call (because it is possible that the called + procedure called another nested procedure and therefore BP was changed. + See emitProcedureEpilogue above. + *) +procedure emitProcedureCall(aProc: ProcRef); +var procLabel: IdentString; +begin + (* pass pointer to stackframe of caller for nested procedures *) + if aProc^.isNested then + begin + if aProc^.level = curProcedure^.level then + emitIns2('LOADREG', 'BP') + else + if aProc^.level > curProcedure^.level then + emitIns2('LOADREG','FP') + else + (* TODO: calling nested aProc with a lower nesting level. + need to chase a chain of old BP pointers. *) + errorExit2('internal error: outward call of nested aProc not implemented', ''); + end; + + emitFpAdjust(-curProcedure^.tempsSize); + + if aProc^.isNested then + begin + getProcedureLabel(aProc, procLabel); + emitIns2('LOADCP', procLabel); + end + else + emitIns2('LOADCP', aProc^.name); + emitIns('CALL'); + + emitFpAdjust(curProcedure^.tempsSize); +end; + +procedure emitFunctionValueReturn(sym: SymblRef); +begin + emitLoadLocal(sym^.offset, sym^.name); +end; + +procedure emitStrCall(typeTag:TypeTagString); +begin + writeln(outfile, #9, 'LOADCP ', typeTag,'STR'); + countIns(1); + writeln(outfile, #9, 'CALL'); +end; + +procedure emitValCall(typeTag:TypeTagString); +begin + writeln(outfile, #9, 'LOADCP ', typeTag,'VAL'); + countIns(1); + writeln(outfile, #9, 'CALL'); +end; + +procedure emitLoadConstStr(c: ConstStrRef); +begin + writeln(outfile, #9, 'LOADCP ', getLocalLabel('_C_S_',c^.no)); + countIns(1); +end; + +procedure emitLoadArrayConst(c: ArrayConstRef); +begin + writeln(outfile, #9, 'LOADCP ', getLocalLabel('_C_A_', c^.id)); +end; + +procedure emitOperator(op: string); +begin + if (op = 'MUL') or (op = 'MULU') or (op = 'DIV') or (op = 'DIVU') or (op = 'MOD') then + emitCall('_' + op) + else + emitIns(op); +end; + +procedure emitShiftMultiple(op: string); +begin + emitCallRaw('_' + op); +end; + +procedure emitFloatOperator(op: string); +begin + emitCall('_' + op + 'FLOAT32'); +end; + +procedure emitTruncFloat; +begin + emitCall('_TRUNCFLOAT32'); +end; + +procedure emitFractFloat; +begin + emitCall('_FRACTFLOAT32'); +end; + +procedure emitIntFloat; +begin + emitCall('_INTFLOAT32'); +end; + +procedure emitSqrInt; +begin + emitDup; + emitOperator('MUL'); +end; + +procedure emitSqrFloat; +begin + emitDup; + emitFloatOperator('MUL'); +end; + +procedure emitIntToFloat; +begin + emitCall('_INTTOFLOAT32'); +end; + +procedure emitComparison(op: string); +begin + emitIns2('CMP', op); +end; + +procedure emitFloatComparison(op: string); +begin + emitCall('_CMPFLOAT32'); + emitLoadConstantInt(0); + emitComparison(op); +end; + +procedure emitIntFloatComparison(op: string); +begin + emitCall('_CMPINTFLOAT32'); + emitLoadConstantInt(0); + emitComparison(op); +end; + +procedure emitStringComparison; +begin + emitCall('_CMPSTRING'); +end; + +procedure emitStringLexiComparison(op: string); +begin + emitCall('_CMPSTRINGL'); + emitLoadConstantInt(0); + emitComparison(op); +end; + +procedure emitMemComparison(var typ: TypeSpec); +begin + emitLoadConstantInt(typ.size div wordSize); + emitCall('_CMPWORDS'); +end; + +procedure emitIsInArray(count:integer); +begin + emitLoadConstantInt(count); + emitCall('_ISINTINARRAY'); +end; + +procedure emitIsInString; +begin + emitCall('_ISCHARINSTRING'); +end; + + +procedure emitIsInSet; +begin + emitCallRaw('_TESTBIT'); +end; + +procedure emitAddToSet; +begin + emitCallRaw('_SETBIT'); +end; + +procedure emitRemoveFromSet; +begin + emitCallRaw('_CLEARBIT'); +end; + +procedure emitArrayToSet(len:integer); +begin + emitLoadConstantInt(len); + emitCall('_ARRAYTOSET'); +end; + +(* emitInc and emitDec emit different instruction sequences + depending on the amount: For a zero amount, nothing is emitted, + for small values INC/DEC are used, otherwise LOADC/LOADCP and + ADD/SUB *) + +procedure emitInc(amount: integer); +begin + if amount = 0 then + begin + (* nothing to do *) + end + else + if amount <= MaxTinyOffset then + emitIns2Int('INC', amount) + else + begin + emitLoadConstantInt(amount); + emitIns('ADD'); + end; +end; + +procedure emitDec(amount: integer); +begin + if amount = 0 then + begin + (* nothing to do *) + end + else + if amount <= MaxTinyOffset then + emitIns2Int('DEC', amount) + else + begin + emitLoadConstantInt(amount); + emitIns('SUB'); + end; +end; + +procedure emitNegate; +begin + emitOperator('NOT'); + emitInc(1); +end; + +procedure emitAbsInt; +begin + emitCallRaw('ABS'); +end; + +procedure emitBooleanNot; +begin + emitIns2Int('LOADC', 0); + emitIns('CMP EQ'); +end; + +procedure emitNot; +begin + emitIns('NOT'); +end; + +procedure emitOdd; +begin + emitIns2Int('LOADC',1); + emitIns('AND'); +end; + +procedure emitSetAdd; +begin + emitIns('OR'); +end; + +procedure emitSetSubtract; +begin + emitIns('NOT'); + emitIns('AND'); +end; + +procedure emitSetIntersect; +begin + emitIns('AND'); +end; + +procedure emitSetCompare; +begin + emitIns('CMP EQ'); +end; + +procedure emitSetCompareNE; +begin + emitIns('CMP NE'); +end; + +procedure emitSetIsSubset; +begin + emitSetSubtract; + emitBooleanNot; +end; + +procedure emitIfBranch(no: integer); +begin + writeln(outfile, #9, '.LCBRANCHZ ', getLocalLabel('_IF_ELSE', no)); + countIns(6); +end; + +procedure emitElseBranch(no: integer); +begin + writeln(outfile, #9, '.LBRANCH ', getLocalLabel('_IF_END', no)); + countIns(5); (* worst case for .LBRANCH is 10 bytes *) + CPoolIfLowMark(false); +end; + +procedure emitIfLabel(no: integer); +begin + emitLocalLabel('_IF_END', no); +end; + +procedure emitElseLabel(no: integer); +begin + emitLocalLabel('_IF_ELSE', no); +end; + +procedure emitWhileStart(no: integer); +begin + emitLocalLabel('_WHILE_START', no); +end; + +procedure emitWhileBranch(no: integer); +begin + writeln(outfile, #9, '.LCBRANCHZ ', getLocalLabel('_WHILE_END', no)); + countIns(6); +end; + +procedure emitWhileEnd(no: integer); +begin + writeln(outfile, #9, '.LBRANCH ', getLocalLabel('_WHILE_START', no)); + countIns(5); + CPoolIfLowMark(false); + emitLocalLabel('_WHILE_END', no); +end; + +function getEndLabel(name:IdentString; no: integer):IdentString; +var nstr: string[24]; +begin + str(no, nstr); + getEndLabel := '_' + name + '_END' + nstr + globalSuffix; +end; + +function getWhileEndLabel(no: integer):IdentString; +begin + getWhileEndLabel := getEndLabel('WHILE', no); +end; + +procedure emitRepeatStart(no: integer); +begin + emitLocalLabel('_REPEAT_START', no); +end; + +procedure emitRepeatBranch(no: integer); +begin + writeln(outfile, #9, '.LCBRANCHZ ', getLocalLabel('_REPEAT_START', no)); + countIns(6); +end; + +procedure emitRepeatEnd(no: integer); +begin + emitLocalLabel('_REPEAT_END', no); +end; + +function getRepeatEndLabel(no: integer):IdentString; +begin + getRepeatEndLabel := getEndLabel('REPEAT', no); +end; + +procedure emitForStart(no: integer); +begin + curProcedure^.estackCleanup := curProcedure^.estackCleanup + 1; + emitLocalLabel('_FOR_START', no); +end; + +procedure emitForBranch(no: integer); +begin + emitIns('OVER'); + emitComparison('GT'); + writeln(outfile, #9, '.LCBRANCH ', getLocalLabel('_FOR_END', no)); + countIns(6); +end; + +procedure emitForDowntoBranch(no: integer); +begin + emitIns('OVER'); + emitComparison('LT'); + writeln(outfile, #9, '.LCBRANCH ', getLocalLabel('_FOR_END', no)); + countIns(6); +end; + +procedure emitForEnd(no: integer); +begin + writeln(outfile, #9, '.LBRANCH ', getLocalLabel('_FOR_START', no)); + countIns(5); + CPoolIfLowMark(false); + emitLocalLabel('_FOR_END', no); + emitIns('DROP'); + curProcedure^.estackCleanup := curProcedure^.estackCleanup - 1; +end; + +procedure emitForInStrHeader; +begin + emitDup; + emitLoadIndirect; + emitSwap; + emitInc(StringHeaderSize); +end; + +procedure emitForInHeader(count:integer); +begin + emitLoadConstantInt(count); + emitSwap; +end; + +procedure emitForInStart(no:integer); +begin + emitForStart(no); + (* emitForStart increments estackCleanup by one, for in uses two + estack elements so add one more *) + curProcedure^.estackCleanup := curProcedure^.estackCleanup + 1; + emitIns('OVER'); + writeln(outfile, #9, '.LCBRANCHZ ', getLocalLabel('_FOR_END', no)); + countIns(6); +end; + +(* sym and mem are the symbol reference and memory location + of the loop variable *) +procedure emitForInStrMid(sym:SymblRef; mem:MemLocation); +begin + (* if the loop variable is a local variable and can be accessed + with a short load/store, then the stack layout at this point is: + [ count, char ptr ] + Otherwise, it is: + [ count, char ptr, loop var addr ] + so we have to use different instructions for each case *) + if isShortLoadStore(mem) then + emitIns('DUP') + else + emitIns('OVER'); + emitIns('LOADI.S1.X2Y'); + emitIns('BSEL'); +end; + +(* sym and mem are the symbol reference and memory location + of the loop variable *) +procedure emitForInMid(sym:SymblRef; srcMem:MemLocation); +begin + (* if the loop variable is a local variable and can be accessed + with a short load/store, then the stack layout at this point is: + [ count, char ptr ] + Otherwise, it is: + [ count, char ptr, loop var addr ] + so we have to use different instructions for each case *) + if isScalar(sym^.symType) and isShortLoadStore(srcMem) then + emitIns('DUP') + else + emitIns('OVER'); +end; + +procedure emitForInStrIter(no:integer); +begin + emitInc(1); + emitSwap; + emitDec(1); + emitSwap; + writeln(outfile, #9, '.LBRANCH ', getLocalLabel('_FOR_START',no)); + countIns(5); +end; + +procedure emitForInIter(no:integer; var typ:TypeSpec); +begin + emitInc(typ.elementType^.size); + emitSwap; + emitDec(1); + emitSwap; + writeln(outfile, #9, '.LBRANCH ', getLocalLabel('_FOR_START',no)); + countIns(5); +end; + +procedure emitForInEnd(no:integer); +begin + CPoolIfLowMark(false); + emitLocalLabel('_FOR_END',no); + emitIns('DROP'); + emitIns('DROP'); + curProcedure^.estackCleanup := curProcedure^.estackCleanup - 2; +end; + +function getForEndLabel(no: integer):IdentString; +begin + getForEndLabel := getEndLabel('FOR', no); +end; + +procedure emitCaseStart(no:integer); +begin + curProcedure^.estackCleanup := curProcedure^.estackCleanup + 1; +end; + +procedure emitCaseLabelLabel(no,valueNo,subVal: integer); +begin + writeln(outfile, '_CASE_', no,'_', valueNo, '_', subVal, globalSuffix, ':'); +end; + +procedure emitCaseLabelStart(no,valueNo,subVal: integer); +begin + emitCaseLabelLabel(no, valueNo, subVal); + emitDup; +end; + +procedure emitCaseLabelBranchOp(cmpOp:string; no, valueNo, subVal: integer; last: boolean); +begin + emitIns2('CMP', cmpOp); + writeln(outfile, #9, '.LCBRANCH ', '_CASE_', no, '_', valueNo, '_', subVal + 1, + globalSuffix); + countIns(5); + if not last then + begin + writeln(outfile, #9, '.LBRANCH ', '_CASE_', no, '_', valueNo, 'M', globalSuffix); + countIns(5); + end +end; + +procedure emitCaseLabelBranch(no, valueNo, subVal: integer; last: boolean); +begin + emitCaseLabelBranchOp('NE', no, valueNo, subVal, last); +end; + +procedure emitCaseRangeLoBranch(no, valueNo, subVal: integer; last: boolean); +begin + emitCaseLabelBranchOp('LT', no, valueNo, subVal, last); + emitDup; +end; + +procedure emitCaseRangeHiBranch(no, valueNo, subVal: integer; last: boolean); +begin + emitCaseLabelBranchOp('GT', no, valueNo, subVal, last); +end; + +procedure emitCaseLabelMatch(no, valueNo: integer); +begin + writeln(outfile, '_CASE_', no, '_', valueNo,'M', globalSuffix, ':'); +end; + +procedure emitCaseLabelEnd(no: integer); +begin + writeln(outfile, #9, '.LBRANCH ', '_CASE_', no, globalSuffix, '_END'); + countIns(5); + CPoolIfLowMark(false); +end; + +procedure emitCaseEnd(no, valueNo: integer); +begin + writeln(outfile, '_CASE_', no, '_', valueNo, globalSuffix, ':'); + writeln(outfile, '_CASE_', no, globalSuffix, '_END', ':'); + emitIns('DROP'); + curProcedure^.estackCleanup := curProcedure^.estackCleanup - 1; +end; + +procedure emitBreak(var aLabl:IdentString); +begin + emitIns2('.LBRANCH', aLabl); + countIns(4); (* worst case for .LBRANCH is 10 bytes *) +end; + +procedure emitAbsFloat32; +begin + emitIns2('LOADCP','$7FFFFFFF'); + emitIns('AND'); +end; + +procedure emitNegFloat32; +begin + emitCallRaw('_NEGFLOAT32'); + (* alternatively, just emit the + code for it: + emitDup; + emitIns2('CBRANCH.Z', '@+6'); + emitIns2('LOADCP','$80000000'); + emitIns('XOR'); + *) +end; diff --git a/pcomp/float32+.pas b/pcomp/float32+.pas new file mode 100644 index 0000000..346c383 --- /dev/null +++ b/pcomp/float32+.pas @@ -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; diff --git a/pcomp/float32+tdr.pas b/pcomp/float32+tdr.pas new file mode 100644 index 0000000..5ce8ce1 --- /dev/null +++ b/pcomp/float32+tdr.pas @@ -0,0 +1,2 @@ +(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *) +function encodefloat32(r:real):integer; external; diff --git a/pcomp/libgen.pas b/pcomp/libgen.pas new file mode 100644 index 0000000..b8ecc94 --- /dev/null +++ b/pcomp/libgen.pas @@ -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. diff --git a/pcomp/lsymgen.pas b/pcomp/lsymgen.pas new file mode 100644 index 0000000..619129e --- /dev/null +++ b/pcomp/lsymgen.pas @@ -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. diff --git a/pcomp/make.bat b/pcomp/make.bat new file mode 100644 index 0000000..22157a6 --- /dev/null +++ b/pcomp/make.bat @@ -0,0 +1,38 @@ +del *.s +del ..\lib\*.lib +del ..\lib\stdlib.s + +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 ..\lib\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 ..\examples\chase.pas +py pcomp.py ..\tests\cchangetest.pas +py pcomp.py ..\tests\tree.pas diff --git a/pcomp/pcomp.pas b/pcomp/pcomp.pas new file mode 100644 index 0000000..8c8c310 --- /dev/null +++ b/pcomp/pcomp.pas @@ -0,0 +1,6452 @@ +(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *) +program PascalCompiler; +{$R+} +{$!}{$ifdef FPC}uses math,crt;{$endif} + +type TokenType = ( + AssignmentToken, PlusToken, MinusToken, AsteriskToken, SlashToken, + SemicolonToken, EOFToken, PointerToken, + CommentStartToken, CommentEndToken, CommentAltStartToken, CommentAltEndToken, + NumberToken, + IdentToken, StringLitToken, CharLitToken, + StringToken, IntegerToken, + BooleanToken, RealToken, CharToken, TrueToken, FalseToken, + LabelToken, GotoToken, + IfToken, ThenToken, ElseToken, WhileToken, + RepeatToken, DoToken, UntilToken, ForToken, ToToken, InToken, + DowntoToken, BreakToken, ContinueToken, + BeginToken, EndToken, WithToken, + VarToken, TypeToken, CaseToken, ConstToken, RecordToken, + CommaToken, EqToken, EqEqToken, NotEqToken, LtToken, + LtEqToken, GtToken, GtEqToken, LParenToken, RParenToken, + LBracketToken, RBracketToken, ColonToken, + NotToken, AndToken, OrToken, XorToken, DivToken, ModToken, + ShlToken, ShrToken, NilToken, + ProcedureToken, FunctionToken, + ArrayToken, OfToken, DotToken, SetToken, + ForwardToken, ExternalToken, ProgramToken, PackedToken, + UnitToken, ImplementationToken, InterfaceToken, UsesToken, + UnknownToken + ); + + IdentString = string[120]; + CompOpString = string[4]; + KeywordString = string[255]; + TypeTagString = string[8]; + + StringRef = ^string; + + SymbolScope = ( GlobalSymbol, LocalSymbol, ParameterSymbol, WithStmntSymbol ); + SymbolType = ( NoType, IntegerType, StringType, RealType, BooleanType, CharType, + ArrayType, RecordType, PointerType, StringCharType, EnumType, + SetType, UnresolvedType ); + + SpecialProc = ( NoSP, NewSP, DisposeSP, ReadSP, WriteSP, ReadlnSP, WritelnSP, + SetlengthSP, ValSP, StrSP, ExitSP ); + SpecialFunc = ( NoSF, TruncSF, FracSF, IntSF, SqrSF, SuccSF, PredSF, + OddSF, ChrSF, OrdSF, AbsSF); + + Token = record + tokenText: string[255]; + tokenKind: TokenType; + end; + + StringList = record + head: ^StringListItem; + tail: ^StringListItem; + current: ^StringListItem; + end; + + StringListItem = record + value: IdentString; + next: ^StringListItem; + end; + + IntList = record + head: ^IntListItem; + tail: ^IntListItem; + current: ^IntListItem; + end; + + IntListItem = record + value: integer; + next: ^IntListItem; + end; + + TypeSpec = record + size: integer; (* size in bytes *) + subStart: integer; + subEnd: integer; + hasSubrange: boolean; + case baseType: SymbolType of + IntegerType,RealType,BooleanType,CharType: (); + EnumType: (enumId, enumLength: integer; enumList: StringList); + StringType: (stringLength: integer); (* max length *) + ArrayType: (arrayLength, arrayStart, arrayEnd: integer; + elementType: ^TypeSpec; indexEnumId: integer); + RecordType: (fields: ^FieldListItem); + PointerType: (pointedType: ^TypeSpec); + SetType: (memberBaseType: SymbolType; memberEnumId: integer); + StringCharType: (); (* used internally when getting a char from a string *) + UnresolvedType:(sourceLine:integer; typeName: ^IdentString); + end; + + TypeSpecPtr = ^TypeSpec; + + TypeRef = ^TypeItem; + + TypeItem = record + typePtr: ^TypeSpec; + name: IdentString; + next: TypeRef; + end; + + FieldListItem = record + fieldType: TypeSpec; + name: IdentString; + offset: integer; + isVariant: boolean; + tagField: ^FieldListItem; + tagValues: IntList; + next: ^FieldListItem; + end; + + FieldRef = ^FieldListItem; + + SymblRef = ^Symbl; + Symbl = record + name: IdentString; + symType: TypeSpec; + scope: SymbolScope; + level: integer; + size: integer; + offset: integer; + isParam: boolean; + isVarParam: boolean; + isConst: boolean; + isExternal: boolean; + initialized: boolean; + initialValue: integer; + hasInitialValue: boolean; + withStmntSlot: integer; + next: SymblRef; + end; + + MemLocType = (NoMem, GlobalMem, LocalMem, NestedMem, Indirect, TemporaryMem, OnStack); + + MemLocation = record + memLoc: MemLocType; + offset: integer; + scopeDistance: integer; + name: IdentString; + typ: TypeSpec; + initialized: boolean; + origSym: SymblRef; + end; + + SymbolTable = record + first: SymblRef; + offset: integer; + scope: SymbolScope; + level: integer; + end; + + LablRef = ^Labl; + Labl = record + name: IdentString; + id: integer; + next: LablRef; + end; + + OpaqueDataElement = record + (* TODO: need optional string values here + if we want to have readable record fields + or arrays of string type *) + next: ^OpaqueDataElement; + case isStringValue: boolean of + false: (intValue: integer); + true: (strValue: ^string; maxLength:integer); + end; + + OpaqueDataRef = ^OpaqueDataElement; + + ArrayConstList = record + id: integer; + count: integer; + firstElement: ^OpaqueDataElement; + next: ^ArrayConstList; + extraLabel: ^IdentString; + end; + + ArrayConstRef = ^ArrayConstList; + + ConstStrRef = ^ConstStr; + ConstStr = record + no: integer; + value: string[255]; + length: integer; + extraLabel: ^IdentString; + next: ConstStrRef; + end; + + ConstListItem = record + next: ^ConstListItem; + name: IdentString; + typ: TypeSpec; + realValue: real; + intValue: integer; + arrayValue: ArrayConstRef; (* FIXME: rename to opaqueValue or similar *) + strValue: ConstStrRef; + enumRef: TypeRef; + end; + + ConstRef = ^ConstListItem; + + ProcRef = ^Proc; + Proc = record + name: IdentString; + id: integer; + parent: ProcRef; + level: integer; + isForward: boolean; + isNested: boolean; + hasNested: boolean; + parameters: SymbolTable; + vars: SymbolTable; + returnType: TypeSpec; + returnsAggregate: boolean; + next: ProcRef; + procedures: ProcRef; + labels: LablRef; + constants: ConstRef; + types: TypeRef; + unresolved: TypeRef; + tempsSize: integer; + estackCleanup: integer; + hasExit: boolean; + end; + + WithStmntAnchor = record + recordLoc: MemLocation; + tempLoc: MemLocation; + tmpSymbol: SymblRef; + end; + +{$I 'platform-types+.pas' } + + InputFileState = record + name: string; + filevar: InputFileType; + line: integer; + end; + +const insSize = 2; + wordSize = 4; + lowCpoolMark = 240; + highCpoolMark = 400; + StringHeaderSize = 8; + MaxUShortOffset = 8191; + MaxShortOffset = 4095; + MaxShorterOffset = 511; + MaxTinyOffset = 15; + WithStackDepth = 8; + DefaultStringLength = 80; + MaxIntegerDigits = 24; + Float32ExpBits = 8; + Float32FractBits = 23; + Float32ExpBias = 127; + Float32ExpMax = 255; + wordBits = 32; + startAddress = 24576; + MaxIncludes = 4; + StdLibName = 'stdlib'; + UnitSuffix1 = '.inc'; + UnitSuffix2 = '.lib'; + FilenameSuffix = '.pas'; + OutfileSuffix = '.s'; + InputFileName = 'INPUT'; + OutputFileName = 'OUTPUT'; + FileTypeName = 'FILE'; + PlatformTag = 'tdr'; + PlatformMagic = '+'; + ProgressSteps = 255; +var + keywords: array [TokenType] of string[32] = ( + ':=', '+', '-', '*', '/', ';' , '', '^', '{', '}', '(*', '*)', + 'number', 'identifier', '$', 'c', + 'STRING', 'INTEGER', 'BOOLEAN', 'REAL', 'CHAR', 'TRUE', 'FALSE', + 'LABEL', 'GOTO', 'IF', 'THEN', 'ELSE', + 'WHILE', 'REPEAT', 'DO', 'UNTIL', 'FOR', 'TO', 'IN', + 'DOWNTO', 'BREAK', 'CONTINUE', + 'BEGIN', 'END', 'WITH', + 'VAR', 'TYPE', 'CASE', 'CONST', 'RECORD', + ',', '=', '==', '!=', '<', '<=', '>', '>=', + '(', ')', '[', ']', ':', 'NOT', 'AND', 'OR', 'XOR', 'DIV', 'MOD', + 'SHL', 'SHR', 'NIL', + 'PROCEDURE', 'FUNCTION', + 'ARRAY', 'OF', '.', 'SET', + 'FORWARD', 'EXTERNAL', 'PROGRAM', 'PACKED', + 'UNIT', 'IMPLEMENTATION', 'INTERFACE', 'USES', + '_' ); + specialprocnames: array [SpecialProc] of string[12] = ( + '_', 'NEW', 'DISPOSE', 'READ', 'WRITE', 'READLN', 'WRITELN', 'SETLENGTH', + 'VAL','STR', 'EXIT'); + specialfuncnames: array [SpecialFunc] of string[8] = ( + '_', 'TRUNC', 'FRAC', 'INT', 'SQR', 'SUCC', 'PRED', 'ODD', + 'CHR', 'ORD', 'ABS' ); + typenames: array[SymbolType] of string[8] = ( + 'NONE?', 'INTEGER', 'STRING', 'REAL', 'BOOLEAN', 'CHAR', 'ARRAY', 'RECORD', + 'POINTER', 'STRCHR?', 'ENUM', 'SET', 'UNRES?' + ); + curToken, nextToken, lastToken: Token; + bufferedChar: char; + buffered: boolean; + infile: InputFileType; + outfile: text; + filename: string; + outfilename: string; + lineno: integer; + ifCount: integer; + whileCount: integer; + forCount: integer; + repeatCount: integer; + caseCount: integer; + nestedProcsCount: integer; + enumCount: integer; + anonTypeCount: integer; + curBreakLabel: IdentString; + firstConstStr, lastConstStr: ConstStrRef; + firstArrayConst, lastArrayConst: ArrayConstRef; + constStrNo: integer; + arrayConstNo: integer; + curProcedure: ProcRef; + mainProcedure: ProcRef; + defaultHeapSize: integer; + defaultStackSize: integer; + insCount: integer; + emptyIntList: IntList; + withStmntStack: array [1..WithStackDepth] of WithStmntAnchor; + withStmntCount: integer; + globalSuffix: IdentString; + fileTyp: TypeSpec; + useStdlib, useStandalone: boolean; + editOnError, runAsm, runProg: boolean; + paramPos: integer; + prevFiles: array[1..MaxIncludes] of InputFileState; + includeLevel: integer; + usedUnits: StringList; + outputPrefix: string[16]; + includePrefix: string[16]; + +procedure errorExit2(message1, message2: string); forward; +procedure errorExit1(message1: string); forward; +procedure checkDuplicateSymbol(var name:IdentString); forward; +function getStringWordCount(maxLength: integer): integer; forward; +procedure readNextToken; forward; +procedure matchToken(kind: TokenType); forward; +function checkToken(kind: TokenType): boolean; forward; +procedure parseExpression(var typeReturn: TypeSpec); forward; +procedure errorLine(line:integer); forward; +procedure errorExit; forward; +function isScalar(var typ: TypeSpec): boolean; forward; +function isFunction(aProc: ProcRef): boolean; forward; +procedure getRangePart(var value:integer; var typeReturn: TypeSpec); forward; +function parseInteger: Integer; forward; +procedure parseLvalue(var memLocReturn: MemLocation); forward; +procedure parseSpecialFunction(sf: SpecialFunc; var returnType: TypeSpec); forward; +procedure parseArrayIndex(var arrayTyp: TypeSpec; var name:IdentString; + var elType:TypeSpec); forward; +procedure parseStringIndex; forward; +procedure parseTypeSpec(var typSpec: TypeSpec; allowUnresolved:boolean); forward; +procedure parseEnumDecl(var name:IdentString;var typeReturn: TypeSpec); forward; +procedure parseConstValue(constData: ArrayConstRef; var expectedType: TypeSpec); forward; +procedure parseProgramBlock; forward; +procedure parseStatement; forward; +function findProcedure(var name: IdentString; aProc:ProcRef): ProcRef; forward; +procedure parseProcedure; forward; +procedure parseFunction; forward; +procedure parseCharExprTail(var typeA: TypeSpec); forward; +procedure parseStringExprTail(dstType: TypeSpec); forward; +procedure parseSetExprTail(var typeA: TypeSpec); forward; +procedure loadVarParamRef(var loc: MemLocation); forward; +procedure loadAddr(var loc: MemLocation); forward; +procedure allocTemporary(aProc: ProcRef; + var typ: TypeSpec; var memLocReturn: MemLocation); forward; +procedure disposeWithStmntTmp; forward; +procedure convertToIndirect(var mem: MemLocation); forward; +function matchTokenOrNot(wantedToken: TokenType): boolean; forward; + +{$I 'platform+.pas'} +{$I 'float32+.pas'} +{$I 'emit.pas'} + +procedure initStringList(var list:StringList); +begin + with list do + begin + head := nil; + tail := nil; + current := nil; + end; +end; + +procedure addToStringList(var list:StringList; var name: IdentString); +var itemRef: ^StringListItem; +begin + new(itemRef); + itemRef^.value := name; + itemRef^.next := nil; + + with list do + begin + if head = nil then + begin + head := itemRef; + tail := itemRef; + current := itemRef; + end + else + begin + head^.next := itemRef; + head := itemRef; + end; + end; +end; + +function nextStringListItem(var list:StringList; var returnStr: IdentString): boolean; +begin + if list.current = nil then + nextStringListItem := false + else + begin + returnStr := list.current^.value; + list.current := list.current^.next; + nextStringListItem := true; + end; +end; + +procedure rewindStringList(var list:StringList); +begin + list.current := list.tail; +end; + +procedure disposeStringList(var list:StringList); +var itemRef, next: ^StringListItem; +begin + itemRef := list.tail; + while itemRef <> nil do + begin + next := itemRef^.next; + dispose(itemRef); + itemRef := next; + end; +end; + +procedure initIntList(var list:IntList); +begin + with list do + begin + head := nil; + tail := nil; + current := nil; + end; +end; + +procedure addToIntList(var list:IntList; var anInteger: integer); +var itemRef: ^IntListItem; +begin + new(itemRef); + itemRef^.value := anInteger; + itemRef^.next := nil; + + with list do + begin + if head = nil then + begin + head := itemRef; + tail := itemRef; + current := itemRef; + end + else + begin + head^.next := itemRef; + head := itemRef; + end; + end; +end; + +function nextIntListItem(var list:IntList; var returnValue: integer): boolean; +begin + if list.current = nil then + nextIntListItem := false + else + begin + returnValue := list.current^.value; + list.current := list.current^.next; + nextIntListItem := true; + end; +end; + +procedure rewindIntList(var list:IntList); +begin + list.current := list.tail; +end; + +procedure disposeIntList(var list:IntList); +var itemRef, next: ^IntListItem; +begin + itemRef := list.tail; + while itemRef <> nil do + begin + next := itemRef^.next; + dispose(itemRef); + itemRef := next; + end; +end; + +function findSymbol(var table: SymbolTable; var name: IdentString): SymblRef; +var current: SymblRef; +begin + current := table.first; + while (current <> nil) do + if (current^.name <> name) then + current := current^.next + else + break; + findSymbol := current; +end; + +function addSymbol(var table: SymbolTable; var name: IdentString; var typ: TypeSpec; + isParam, isVarParam: boolean): SymblRef; +var current: SymblRef; + newSymbol: SymblRef; +begin + checkDuplicateSymbol(name); + + new(newSymbol); + newSymbol^.name := name; + newSymbol^.offset := table.offset; + newSymbol^.next := nil; + newSymbol^.scope := table.scope; + newSymbol^.level := table.level; + newSymbol^.size := typ.size; + newSymbol^.symType := typ; (* TODO: needs a deep copy for aggregate types *) + newSymbol^.isParam := isParam; + newSymbol^.isVarParam := isVarParam; + newSymbol^.isExternal := false; + newSymbol^.initialized := (table.scope = GlobalSymbol) or isVarParam or isParam; + + if isVarParam then + table.offset := table.offset + wordSize + else + table.offset := table.offset + typ.size; + + emitNewSymbol(table.scope, name, newSymbol^.offset); + + if table.first = nil then + table.first := newSymbol + else + begin + current := table.first; + while current^.next <> nil do current := current^.next; + current^.next := newSymbol; + end; + + addSymbol := newSymbol; +end; + +(* Create a pseudo symbol for a record field that is accessed inside + a with statement. + Because we need to return a pointer to a symbol in findHieraSymbol, + we have to allocate a TypeSpec record which needs to be freed later + (in parseWithStatement) + *) +function createPseudoSym(var name: string; field: FieldRef; + withSlot: integer): SymblRef; +var sym: SymblRef; + typ: TypeSpec; +begin + typ := field^.fieldType; + + new(sym); + sym^.name := name; + sym^.symType := typ; + sym^.scope := WithStmntSymbol; + sym^.level := 0; + sym^.size := typ.size; + sym^.offset := field^.offset; + sym^.isParam := false; + sym^.isVarParam := false; + sym^.isConst := false; + sym^.isExternal := false; + sym^.initialized := false; + sym^.initialValue := 0; + sym^.hasInitialValue := false; + sym^.withStmntSlot := withSlot; + sym^.next := nil; + + createPseudoSym := sym; +end; + +function findWithStmntSym(var name: string): SymblRef; +var sym: SymblRef; + i: integer; + w: WithStmntAnchor; + field: ^FieldListItem; +begin + sym := nil; + + for i := withStmntCount downto 1 do + begin + w := withStmntStack[i]; + field := w.recordLoc.typ.fields; + while field <> nil do + begin + if field^.name = name then + begin + sym := createPseudoSym(name, field, i); + (* If there was a pseudo-symbol allocated earlier, + free it. The last one is freed in parseWithStatement. + We can overwrite the previous pointer because it is only + used from findHieraSymbol until initMemLocation/parseMemlocation. + The call sequence looks like this: + - findHieraSymbol -> pseudo-sym allocated + - initMemLocation -> used + - read/writeVariable -> ignored + + If we have multiple accesses to the same record within a + statement, the call sequence is as follows: + - findHieraSymbol a -> allocate psym for a + - initMemLocation a -> psym-a is used + - findHieraSymbol b -> allocate for b, free psym-a + - initMemLocation b -> psym-b is used + - readVariable b -> memloc-b is used + - writeVariable a -> memloc-a is used + *) + disposeWithStmntTmp; + withStmntStack[i].tmpSymbol := sym; + break; + end; + field := field^.next; + end; + + if sym <> nil then + break; + end; + + findWithStmntSym := sym; +end; + +function findHieraSymbol(var name: string): SymblRef; +var sym: SymblRef; + aProc: ProcRef; +begin + + (* TODO: check the with-stack, use WithScope in that case. + Also add this to initMemLocation/parseMemLocation *) + sym := nil; + aProc := curProcedure; + + sym := findWithStmntSym(name); + + (* if not a record field from a with statement, check + for variable names recursively *) + if (sym = nil) and (aProc <> nil) then + (* aProc can be nil during the initialization of the main procedure *) + repeat + sym := findSymbol(aProc^.vars, name); + if sym = nil then + aProc := aProc^.parent; + until (sym <> nil) or (aProc = nil); + + findHieraSymbol := sym; +end; + +function findConstant(aProc:ProcRef; var name:IdentString): ConstRef; +var current: ConstRef; +begin + current := aProc^.constants; + while current <> nil do + begin + if current^.name = name then + break + else + current := current^.next; + end; + findConstant := current; +end; + +function findConstantHiera(var name:IdentString): ConstRef; +var aProc:ProcRef; +begin + findConstantHiera := nil; + aProc := curProcedure; + while aProc <> nil do + begin + findConstantHiera := findConstant(aProc, name); + if findConstantHiera <> nil then + break + else + aProc := aProc^.parent; + end; +end; + +function addConstant(var name:IdentString): ConstRef; +var current,newConst: ConstRef; +begin + checkDuplicateSymbol(name); + + new(newConst); + newConst^.name := name; + newConst^.next := nil; + newConst^.typ.baseType := NoType; + + if curProcedure^.constants = nil then + curProcedure^.constants := newConst + else + begin + current := curProcedure^.constants; + while current^.next <> nil do current := current^.next; + current^.next := newConst; + end; + addConstant := newConst; +end; + +function findLabel(var aProc: ProcRef; var name: IdentString): LablRef; +var current: LablRef; +begin + current := aProc^.labels; + while (current <> nil) do + begin + if current^.name = name then + break + else + current := current^.next; + end; + findLabel := current; +end; + +procedure addLabel(var aProc: ProcRef; var name: IdentString); +var current, newLabl: ^Labl; +begin + checkDuplicateSymbol(name); + + new(newLabl); + newLabl^.name := name; + newLabl^.id := aProc^.id; + newLabl^.next := nil; + + if aProc^.labels = nil then + aProc^.labels := newLabl + else + begin + current := aProc^.labels; + while current^.next <> nil do current := current^.next; + current^.next := newLabl; + end; +end; + +function addArrayConst: ArrayConstRef; +var newArrayConst: ArrayConstRef; +begin + arrayConstNo := arrayConstNo + 1; + + new(newArrayConst); + newArrayConst^.firstElement := nil; + newArrayConst^.next := nil; + newArrayConst^.id := arrayConstNo; + newArrayConst^.extraLabel := nil; + + if firstArrayConst = nil then + firstArrayConst := newArrayConst + else + lastArrayConst^.next := newArrayConst; + + lastArrayConst := newArrayConst; + + addArrayConst := newArrayConst; +end; + +function addNamedArrayConst(var name:IdentString; var first:boolean): ArrayConstRef; +var constData: ArrayConstRef; +begin + constData := addArrayConst; + if first then + begin + new(constData^.extraLabel); + constData^.extraLabel^ := name; + first := false; + end; + addNamedArrayConst := constData; +end; + +function addConstElem(arrayConst: ArrayConstRef): OpaqueDataRef; +var newElem,current: ^OpaqueDataElement; +begin + new(newElem); + newElem^.next := nil; + + current := arrayConst^.firstElement; + if current = nil then + arrayConst^.firstElement := newElem + else + begin + while current^.next <> nil do current := current^.next; + current^.next := newElem; + end; + + addConstElem := newElem; +end; + +procedure addArrayConstElem(arrayConst: ArrayConstRef;value:integer); +var newElem: ^OpaqueDataElement; +begin + newElem := addConstElem(arrayConst); + newElem^.isStringValue := false; + newElem^.intValue := value; +end; + +procedure addStrConstElem(arrayConst: ArrayConstRef; var aString:KeywordString; + maxLength:integer); +var newElem: ^OpaqueDataElement; +begin + if length(aString) > maxLength then + errorExit2('String constant length exceeds declared length',''); + + newElem := addConstElem(arrayConst); + newElem^.isStringValue := true; + new(newElem^.strValue); + newElem^.strValue^ := aString; + newElem^.maxLength := maxLength; +end; + +function findConstStr(var value: string):ConstStrRef; +var current: ConstStrRef; +begin + current := firstConstStr; + while (current <> nil) and (current^.value <> value) do current := current^.next; + findConstStr := current; +end; + +function addConstStrRaw(var value: string): ConstStrRef; +var newstring: ConstStrRef; +begin + new(newstring); + newstring^.value := value; + newstring^.next := nil; + newstring^.no := constStrNo; + newstring^.length := 0; + newstring^.extraLabel := nil; + + constStrNo := constStrNo + 1; + + if lastConstStr = nil then + begin + firstConstStr := newstring; + lastConstStr := newstring; + end + else + begin + lastConstStr^.next := newstring; + lastConstStr := newstring; + end; + addConstStrRaw := newstring; +end; + +(* create a string constant/literal and return a pointer to it. + if a constant with the same value already exists, it is reused. + *) +function addConstStr(var value: string): ConstStrRef; +var newstring: ConstStrRef; +begin + newstring := findConstStr(value); + if newstring = nil then + begin + newstring := addConstStrRaw(value); + end; + addConstStr := newstring; +end; + +procedure nextAnonTypeName(var name:IdentString); +var buf:string[16]; +begin + str(anonTypeCount, buf); + name := '_anon' + buf; + anonTypeCount := anonTypeCount + 1; +end; + +procedure dumpTypes; forward; + +procedure addType(var newType: TypeSpec; var name:IdentString); +var curItem: TypeRef; + newTypeSpec: ^TypeSpec; + newItem: TypeRef; +begin + checkDuplicateSymbol(name); + + curItem := curProcedure^.types; + + new(newTypeSpec); + newTypeSpec^ := newType; + + new(newItem); + newItem^.name := name; + newItem^.typePtr := newTypeSpec; + newItem^.next := nil; + + (* if list is empty, set first item *) + if curItem = nil then + begin + curProcedure^.types := newItem; + end + else + begin + (* find the end of the list *) + while curItem^.next <> nil do + curItem := curItem^.next; + curItem^.next := newItem; + end; + { dumpTypes; } +end; + +function findTypeRef(aProc: ProcRef; var name: IdentString): TypeRef; +var curItem: TypeRef; +begin + findTypeRef := nil; + curItem := aProc^.types; + while curItem <> nil do + begin + if curItem^.name = name then + begin + findTypeRef := curItem; + break; + end; + curItem := curItem^.next; + end; +end; + +function findTypeRefHiera(var name: IdentString): TypeRef; +var aProc:ProcRef; +begin + findTypeRefHiera := nil; + aProc := curProcedure; + while aProc <> nil do + begin + findTypeRefHiera := findTypeRef(aProc, name); + if findTypeRefHiera <> nil then + break + else + aProc := aProc^.parent; + end; +end; + +(* TODO: use findTypeRef *) +function findType(aProc:ProcRef; var name: IdentString): TypeSpec; +var curItem: TypeRef; +begin + findType.baseType := NoType; + curItem := aProc^.types; + while curItem <> nil do + begin + { writeln('***** findType searching ', name, ' ', curItem^.name, + ' ', curItem^.typePtr^.baseType); } + if curItem^.name = name then + begin + findType := curItem^.typePtr^; + { writeln('***** findType found ', curItem^.name); } + break; + end; + curItem := curItem^.next; + end; +end; + +(* TODO: use findTypeRefHiera *) +function findTypeHiera(var name: IdentString): TypeSpec; +var aProc: ProcRef; +begin + findTypeHiera.baseType := NoType; + aProc := curProcedure; + while aProc <> nil do + begin + findTypeHiera := findType(aProc, name); + if findTypeHiera.baseType <> NoType then + break + else + aProc := aProc^.parent; + end; +end; + +function findEnumById(enumId: integer):TypeRef; +var aProc:ProcRef; + curItem: TypeRef; +begin + findEnumById := nil; + aProc := curProcedure; + while (aProc <> nil) and (findEnumById = nil) do + begin + curItem := aProc^.types; + while curItem <> nil do + begin + if (curItem^.typePtr^.baseType = EnumType) + and (curItem^.typePtr^.enumId = enumId) then + begin + findEnumById := curItem; + break; + end; + curItem := curItem^.next; + end; + aProc := aProc^.parent; + end; +end; + +procedure dumpTypes; +var curType: TypeRef; +begin + curType := curProcedure^.types; + while curType <> nil do + begin + writeln(curType^.name:20,' ', curType^.typePtr^.baseType, ' ', + curType^.typePtr^.size); + curType := curType^.next; + end; +end; + +procedure checkDuplicateVar(var name:IdentString); +var typ:TypeSpec; +begin + if curProcedure <> nil then + if findSymbol(curProcedure^.vars, name) <> nil then + errorExit2('duplicate identifier', name); + + typ := findTypeHiera(name); + if typ.baseType <> NoType then + errorExit2('duplicate identifier (type)', name); + + if findConstantHiera(name) <> nil then + errorExit2('duplicate identifier (constant)', name); +end; + +procedure checkDuplicateSymbol(var name:IdentString); +begin + checkDuplicateVar(name); + (* FIXME: this should most likely be searchProcedure, not findProcedure*) + if findProcedure(name, curProcedure) <> nil then + errorExit2('duplicate identifier (procedure/function)', name); +end; + +procedure setBaseType(var typ: TypeSpec; baseTyp: SymbolType); +begin + typ.size := wordSize; + typ.baseType := baseTyp; + typ.hasSubrange := false; +end; + +procedure setSubrange(var typ: TypeSpec; rStart,rEnd: integer); +begin + typ.hasSubrange := true; + typ.subStart := rStart; + typ.subEnd := rEnd; +end; + +(* TODO: wrong name, Pointer is not a scalar *) +function isScalar(var typ: TypeSpec): boolean; +begin + isScalar := typ.baseType in [ IntegerType, BooleanType, RealType, CharType, PointerType, + EnumType ]; +end; + +function isAggregate(var typ:TypeSpec): boolean; +begin + isAggregate := typ.baseType in [ ArrayType, RecordType, StringType ]; +end; + +(* check if type is a single value (used only for constant declaration?)*) +function isSimpleType(var typ: TypeSpec): boolean; +begin + isSimpleType := typ.baseType in [ IntegerType, BooleanType, RealType, CharType, EnumType ]; +end; + +function isDirectType(var typ: TypeSpec): boolean; +begin + isDirectType := typ.baseType in [ IntegerType, BooleanType, RealType, CharType, EnumType, + SetType, PointerType ]; +end; + +(* check if valid type for array indexing *) +function isIndexType(var typ: TypeSpec): boolean; +begin + isIndexType := typ.baseType in [ IntegerType, BooleanType, CharType, EnumType ]; +end; + +procedure setStringTypeSize(var typeReturn:TypeSpec; length:integer); +begin + setBaseType(typeReturn, StringType); + typeReturn.size := StringHeaderSize + ((length div wordSize) + 1) * wordSize; + typeReturn.stringLength := length; +end; + +procedure convertStringToChar(var typeReturn:TypeSpec); +begin + setBaseType(typeReturn, CharType); + emitConvStringToChar; +end; + +procedure convertCharToString(var typeReturn:TypeSpec); +var temp: MemLocation; +begin + setBaseType(typeReturn, StringType); + setStringTypeSize(typeReturn,1); + allocTemporary(curProcedure, typeReturn, temp); + loadAddr(temp); + emitConvCharToString; +end; + +procedure convertIntToReal(var typeReturn:TypeSpec); +begin + setBaseType(typeReturn, RealType); + emitIntToFloat(); +end; + +procedure convertPrevIntToReal(var typeReturn:TypeSpec); +begin + setBaseType(typeReturn, RealType); + emitSwap; + emitIntToFloat(); + emitSwap; +end; + +function getTypeName(t: SymbolType):TypeTagString; +begin + getTypeName := typeNames[t]; +end; + +procedure matchBaseType(var typ: TypeSpec; wantedBaseType: SymbolType); +begin + if typ.baseType <> wantedBaseType then + errorExit1('Error: Expected type ' + getTypeName(wantedBaseType) + + ', got ' + getTypeName(typ.baseType)); +end; + +procedure matchBaseTypes(var typeA, typeB: TypeSpec; wantedBaseType: SymbolType); +begin + matchBaseType(typeA, wantedBaseType); + matchBaseType(typeB, wantedBaseType); +end; + +procedure matchLogicOpTypes(var typeA, typeB:TypeSpec); +begin + if (typeA.baseType <> typeB.baseType) or + ((typeA.baseType <> IntegerType) and + (typeA.baseType <> BooleanType)) then + errorExit2('Either two boolean or two integer operands expected', ''); +end; + +procedure matchSymbolType(actualType: TypeSpec; sym: SymblRef); +begin + (* TODO: match complex types *) + if sym^.symType.baseType <> actualType.baseType then + errorExit1('Error: expected type ' + getTypeName(sym^.symType.baseType) + + ' for ' + sym^.name + ', got ' + getTypeName(actualType.baseType)); +end; + +(* check if two types are the same. + Arrays must have same length and element type. + Records must be the same type alias (that is, + having the same field types is not enough) + + This is like matchTypes but it returns a value + instead of throwing errors. +*) +function isSameType(var typeA, typeB: TypeSpec):boolean; +begin + isSameType := false; + + if typeA.baseType = typeB.baseType then + begin + isSameType := true; (* if the base types match, we set the return + value to true here, with more checks below *) + if typeA.baseType = EnumType then + isSameType := typeA.enumId = typeB.enumId + else + if typeA.baseType = ArrayType then + isSameType := isSameType(typeA.elementType^, typeB.elementType^) and + (typeA.arrayLength = typeB.arrayLength) + else if typeA.baseType = RecordType then + (* the pointer to the first record field works as an unique + identifier, because the field items are allocated + exactly once when compiling and are never deallocated.*) + isSameType := typeA.fields = typeB.fields + else if typeA.baseType = PointerType then + begin + (* pointedType is nil for the nil pointer value + which is compatible with all pointer types *) + if (typeB.pointedType <> nil) and (typeA.pointedType <> nil) then + isSameType := isSameType(typeA.pointedType^, typeB.pointedType^); + end; + end; +end; + +procedure matchTypes(var typeA, typeB: TypeSpec); +begin + matchBaseType(typeA, typeB.baseType); + if typeA.baseType = EnumType then + begin + if typeA.enumId <> typeB.enumId then + errorExit2('Incompatible enum types for', lastToken.tokenText); + end + else + if typeA.baseType = ArrayType then + begin + matchTypes(typeA.elementType^, typeB.elementType^); + if typeA.arrayLength <> typeB.arrayLength then + errorExit2('Incompatible arrays', ''); + end + else if typeA.baseType = RecordType then + begin + (* the pointer to the first record field works as an unique + identifier, because the field items are allocated + exactly once when compiling and are never deallocated.*) + if typeA.fields <> typeB.fields then + errorExit2('Incompatible record types', ''); + end + else if typeA.baseType = PointerType then + begin + (* pointedType is nil for the nil pointer value + which is compatible with all pointer types *) + if (typeB.pointedType <> nil) and (typeA.pointedType <> nil) then + matchTypes(typeA.pointedType^, typeB.pointedType^); + end; +end; + +(* checks if a type is compatible with real. + accepts real or integer. integer will be converted + to real. value must be already on stack. *) +procedure matchRealType(var typeB: TypeSpec); +begin + if typeB.baseType = IntegerType then + convertIntToReal(typeB) + else + matchBaseType(typeB, RealType); +end; + +(* Match argument types for an arithmetic operation of reals. + One of both args can be an integer and will be converted. + Both args must already be on the stack. + *) +procedure matchRealCompatibleArgs(var typeA, typeB: TypeSpec); +begin + if typeA.baseType = IntegerType then + convertPrevIntToReal(typeA); + if typeB.baseType = IntegerType then + convertIntToReal(typeB); + matchBaseType(typeA, RealType); + matchBaseType(typeB, RealType); +end; + +procedure matchComparableTypes(var typeA, typeB: TypeSpec); +begin + if (typeA.baseType = RealType) and (typeB.baseType = IntegerType) then + begin + (* writeln('**** real/integer comparison'); *) + end + else if (typeA.baseType = IntegerType) and (typeB.baseType = RealType) then + begin + (* writeln('**** integer/real comparison'); *) + end + else if (typeA.baseType <> typeB.baseType) then + begin + if (typeA.baseType = CharType) and (typeB.baseType = StringType) then + convertStringToChar(typeB) + else + if (typeA.baseType = StringType) and (typeB.baseType = CharType) then + convertCharToString(typeB) + else + begin + errorExit1('types ' + getTypeName(typeA.baseType) + ' and '+ + getTypeName(typeB.baseType) + ' are not comparable'); + end; + end + else + begin + if not (isScalar(typeA) or (typeA.baseType = StringType)) then + matchTypes(typeA, typeB); + (* FIXME: what happens when the if condition is not met? *) + end; +end; + +(* match types and in some cases, try to convert non-matching types. + typeB is converted to typeA, if needed. A conversion is performed + on the topmost stack element (if any). + currently implemented: string -> char, char -> string, integer -> real + *) +procedure matchAndConvertTypes(var typeA, typeB: TypeSpec); +begin + if (typeA.baseType = CharType) and (typeB.baseType = StringType) then + convertStringToChar(typeB) + else + if (typeA.baseType = StringType) and (typeB.baseType = CharType) then + convertCharToString(typeB) + else + if (typeA.baseType = StringCharType) and (typeB.baseType = CharType) then + (* StringCharType and CharType are compatible and conversion will be + handled by parseMemLocation and readVariable/writeVariable*) + else + if (typeA.baseType = RealType) and (typeB.baseType = IntegerType) then + convertIntToReal(typeB) + else + matchTypes(typeB, typeA); (* reverse order to get correct error message *) +end; + +procedure setIndirect(var mem: MemLocation); +begin + if mem.memLoc <> Indirect then + begin + mem.memLoc := Indirect; + (* mem.name := mem.name + ''; *) + mem.offset := -1; + end; +end; + +procedure initNoMemLocation(var loc: MemLocation); +begin + loc.memLoc := NoMem; + loc.offset := -1; + loc.name := 'NoMem'; + loc.typ.baseType := NoType; +end; + +(* initialize a MemLocation object from a Symbol. *) +procedure initMemLocation(sym: SymblRef; var loc: MemLocation); +begin + loc.memLoc := NoMem; + loc.name := sym^.name; + loc.offset := 0; + loc.typ := sym^.symType; + loc.initialized := sym^.initialized; + loc.origSym := sym; + + if sym^.isVarParam then + begin + (* is it a var parameter from an outer scope? *) + if sym^.level < curProcedure^.level then + begin + loc.memLoc := NestedMem; + loc.offset := sym^.offset; + loc.scopeDistance := curProcedure^.level - sym^.level; + end + else + begin + loc.memLoc := LocalMem; + loc.offset := sym^.offset; + end; + loadVarParamRef(loc); + setIndirect(loc); + (* for var parameters the local variable slot contains + the address of the value + FIXME: loadVarParamRef should not be done here + - why not? + - because it might be possible we want to initialize + the MemLocation record without emitting code + - but we do emit code to start the address calculation + for other cases, too, see below *) + end + else + if sym^.scope = GlobalSymbol then + begin + loc.memLoc := GlobalMem; + (* nothing to do, name and offset are already set *) + end + else if sym^.scope in [ LocalSymbol, ParameterSymbol ] then + begin + (* is it a variable from an outer scope? *) + if sym^.level < curProcedure^.level then + begin + loc.memLoc := NestedMem; + loc.offset := sym^.offset; + loc.scopeDistance := curProcedure^.level - sym^.level; + emitNestedMemLoc(loc); + if isNestedIndirect(loc) then + setIndirect(loc); + end + else + begin + loc.memLoc := LocalMem; + loc.offset := sym^.offset; + emitLocalMemLoc(loc); + if isLocalIndirect(loc) then + setIndirect(loc); + end; + end + else if sym^.scope = WithStmntSymbol then + begin + loc.memLoc := Indirect; + loc.offset := sym^.offset; + emitWithStmntMemLoc(loc, sym^.withStmntSlot); + end + else + errorExit2('Internal error in initMemLocation', sym^.name); +end; + +function findField(var typ:TypeSpec; var name:IdentString): FieldRef; +var curField: FieldRef; +begin + if typ.baseType <> RecordType then + errorExit2('Invalid record field access:', name); + findField := nil; + curField := typ.fields; + while curField <> nil do + begin + if curField^.name = name then + begin + findField := curField; + break; + end; + curField := curField^.next; + end; +end; + +function findSpecialProcedure(var name: IdentString): SpecialProc; +var i: SpecialProc; +begin + findSpecialProcedure := NoSP; + + for i := NoSP to ExitSP do + if name = specialprocnames[i] then + begin + findSpecialProcedure := i; + break; + end; +end; + +function findSpecialFunction(var name: IdentString): SpecialFunc; +var i: SpecialFunc; +begin + findSpecialFunction := NoSF; + + for i := NoSF to AbsSF do + if name = specialfuncnames[i] then + begin + findSpecialFunction := i; + break; + end; +end; + +function findProcedure(var name: IdentString; aProc:ProcRef): ProcRef; +var current: ProcRef; +begin + if aProc <> nil then + begin + current := aProc^.procedures; + while (current <> nil) do + if (current^.name <> name) then + current := current^.next + else + break; + findProcedure := current; + end + else + findProcedure := nil; +end; + +(* do a nested search for a procedure, i.e. search in procedures + at the current scope, then continue search at all outer scopes if not found. *) +function searchProcedure(var name: IdentString): ProcRef; +var parent: ProcRef; +begin + parent := curProcedure; + repeat + searchProcedure := findProcedure(name, parent); + if searchProcedure = nil then parent := parent^.parent; + until (parent = nil) or (searchProcedure <> nil); +end; + +function createProcedure(var name:IdentString; parent:ProcRef):ProcRef; +var newProc, current:ProcRef; +begin + new(newProc); + newProc^.name := name; + newProc^.next := nil; + newProc^.tempsSize := 0; + newProc^.returnsAggregate := false; + newProc^.parent := parent; + newProc^.level := 0; + newProc^.isForward := false; + newProc^.isNested := false; + newProc^.hasNested := false; + newProc^.procedures := nil; + newProc^.labels := nil; + newProc^.types := nil; + newProc^.unresolved := nil; + newProc^.constants := nil; + newProc^.hasExit := false; + newProc^.estackCleanup := 0; + nestedProcsCount := nestedProcsCount + 1; + newProc^.id := nestedProcsCount; + setBaseType(newProc^.returnType, NoType); + + if parent <> nil then + begin + newProc^.level := parent^.level + 1; + if newProc^.level > 0 then newProc^.isNested := true; + + if (parent^.procedures) = nil then + parent^.procedures := newProc + else + begin + current := parent^.procedures; + while current^.next <> nil do current := current^.next; + current^.next := newProc; + end; + end; + + newProc^.vars.first := nil; + newProc^.vars.offset := 0; + newProc^.vars.scope := LocalSymbol; + newProc^.vars.level := newProc^.level; + newProc^.parameters.first := nil; + newProc^.parameters.offset := 0; + newProc^.parameters.level := newProc^.level; + + { + if parent <> nil then + writeln('***** createProcedure ', newProc^.name, ' parent:', newProc^.parent^.name, + ' level:', newProc^.level); + } + + (* do some preparations for the stack frame, + e.g. allocate space for the link to + outer stack frames for nested procedures *) + cpuAllocStackFrame(newProc); + + createProcedure := newProc; +end; + +function addProcedure(name: IdentString; hasReturnValue: boolean; parent:ProcRef): ProcRef; +var fwdDecl:ProcRef; +begin + checkDuplicateVar(name); + + fwdDecl := findProcedure(name, parent); + if fwdDecl <> nil then + begin + if not fwdDecl^.isForward then + errorExit2('duplicate identifier (procedure/function)', name); + addProcedure := fwdDecl; + end + else + addProcedure := createProcedure(name, parent); +end; + +procedure addParam(aProc: ProcRef; name: IdentString; typSpec: TypeSpec; isVarParam: boolean); +var pSym, vSym: SymblRef; +begin + (* parameters are added to both the parameter list and the + list of local variables *) + pSym := addSymbol(aProc^.parameters, name, typSpec, true, isVarParam); + vSym := addSymbol(aProc^.vars, name, typSpec, true, isVarParam); + pSym^.scope := ParameterSymbol; + vSym^.scope := ParameterSymbol; + pSym^.isParam := true; + vSym^.isParam := true; +end; + +procedure printLineStats; +begin + write(#13); + ClrEol; + writeln(filename:16, lineno - 1:8, ' lines.'); +end; + +procedure beginInclude(var newname: string); +var newfile: InputFileType; + p:integer; +begin + if includeLevel = MaxIncludes then + errorExit2('Too many nested includes', ''); + + includeLevel := includeLevel + 1; + + prevFiles[includeLevel].filevar := infile; + prevFiles[includeLevel].name := filename; + prevFiles[includeLevel].line := lineno; + + p := pos(PlatformMagic, newname); + if p > 0 then + insert(PlatformTag, newname, p + 1); + + openFileWithDefault(newfile, newname); + + infile := newfile; + filename := newname; + lineno := 1; + buffered := false; +end; + +procedure endInclude; +begin + if includeLevel = 0 then + errorExit2('Internal error in', 'endInclude'); + + close(infile); + + printLineStats; + + infile := prevFiles[includeLevel].filevar; + filename := prevFiles[includeLevel].name; + lineno := prevFiles[includeLevel].line; + + buffered := false; + + includeLevel := includeLevel - 1; +end; + +function includeIsActive:boolean; +begin + includeIsActive := includeLevel > 0; +end; + +function nextChar: char; +var ch: char; +begin + if buffered then + begin + ch := bufferedChar; + buffered := false; + end + else + begin + if not eof(infile) then + begin + read(infile, ch); + end + else + begin + (* we reached end-of-file, was this + the end of an include file? *) + if includeIsActive then + begin + (* if yes, switch back to previous file *) + endInclude; + ch := ' '; (* return a space which will get skipped *) + end + else + (* no, return null character which becomes an EOFToken *) + ch := #0; + end + end; + if ch = #10 then + begin + lineno := lineno + 1; + if (lineno and ProgressSteps) = 0 then + begin + write(#13, filename, ' ', lineno); + ClrEol; + end; + end; + nextChar := ch; +end; + +procedure skipChar; +var ch:char; +begin + ch := nextChar; +end; + +function peekChar: char; +var tmpChar: char; +begin + if buffered then + begin + peekChar := bufferedChar; + end + else + begin + if not eof(infile) then + begin + read(infile, tmpChar); + peekChar := tmpChar; + bufferedChar := tmpChar; + buffered := true; + end + else + begin + (* at the eof of an include, + just return an extra space and let nextChar + do the work *) + if includeIsActive then + begin + peekChar := ' '; + buffered := false; (* force nextChar to do real I/O *) + end + else + peekChar := #0; + end + end +end; + +procedure skipWhitespace; +begin + while peekChar() in [ #10, #13, #32, #9, #12 ] do + skipChar; +end; + +function findToken(var keyword: string): TokenType; +var i: TokenType; +begin + findToken := UnknownToken; + + for i := StringToken to UnknownToken do + begin + if keywords[i] = keyword then + begin + findToken := i; + break; + end + end +end; + +(* Convert hexadecimal digits to integer like val(). + digits may or may not start with a '$' character. *) +procedure hexVal(var digits:string; var retval:integer; var error:integer); +var i,v,len:integer; + c:char; +begin + len := length(digits); + + if (len > 0) and (digits[1] = '$') then + i := 2 + else + i := 1; + retval := 0; + error := 0; + + while (i <= len) and (error = 0) do + begin + retval := retval shl 4; + c := 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 + error := i; + retval := retval + v; + i := i + 1; + end; +end; + +function integerFromString(digits:KeywordString):integer; +var value,error:integer; +begin + if (length(digits) > 0) and (digits[1] = '$') then + hexVal(digits, value, error) + else + val(digits, value, error); + if error <> 0 then + errorExit2('invalid integer value', digits); + integerFromString := value; +end; + +function getInteger:integer; +var curChar: char; + digits: string[24]; +begin + if peekChar = '-' then + begin + curChar := nextChar; + digits := '-'; + end + else + digits := ''; + + while peekChar in ['0'..'9'] do + begin + curChar := nextChar; + if (length(digits) < MaxIntegerDigits) and (curChar <> #0) then + digits := digits + curChar; + end; + + getInteger := integerFromString(digits); +end; + +function realFromString(var digits:KeywordString): real; +var code: Integer; + v: real; +begin + val(digits, v, code); + if code <> 0 then errorExit2('invalid real value', digits); + realFromString := v; +end; + +function getCharLitValue(tokenText:string):integer; +begin + (* is is a one-character-string-literal like 'A' ? *) + if length(tokenText) = 1 then + getCharLitValue := ord(tokenText[1]) + else + errorExit2('cannot use string as char here', tokenText); +end; + +(* scan for an integer number. the first digit is already in curChar. + digits are written to keyword. *) +procedure getDigits(curChar: char; var keyword: KeywordString); +begin + keyword := keyword + curChar; + while peekChar in [ '0'..'9' ] do + begin + keyword := keyword + nextChar; + end; +end; + +(* Scan for an integer number in hexadecimal format. + The hex marker '$' is already in curChar. + Digits are written to keyword. *) +procedure getHexDigits(curChar: char; var keyword: KeywordString); +begin + keyword := keyword + curChar; + while upcase(peekChar) in [ '0'..'9', 'A'..'F' ] do + begin + keyword := keyword + upcase(nextChar); + end; +end; + +(* Scan for an integer or real number. All digits up to the first non-digit are + already in curToken.tokenText. + Returns all digits/characters in digits and either + IntegerType or RealType in typeReturn *) +procedure getNumber(var digits:IdentString; var typeReturn:TypeSpec); +begin + digits := curToken.tokenText; + + if checkToken(MinusToken) then + begin + readNextToken; + digits := digits + curToken.tokenText; + end; + + if not (peekChar in [ '.', 'E', 'e' ]) then + begin + setBaseType(typeReturn, IntegerType); + end + else + begin + if peekChar = '.' then (* is there a decimal point? *) + begin + digits := digits + nextChar; + if peekChar in [ '0'..'9'] then (* is there a fraction after the decimal point ? *) + begin + getDigits(nextChar, digits); + end; + end; + if peekChar in ['E','e'] then (* is there an exponent? *) + begin + digits := digits + nextChar; + + if peekChar in ['+', '-'] then (* exponent can have a sign *) + begin + digits := digits + nextChar; + end; + + if peekChar in ['0'..'9'] then (* now we require some exponent digits *) + begin + getDigits(nextChar, digits); + end + else + errorExit2('invalid number format', digits); + end; + setBaseType(typeReturn, RealType); + end; + readNextToken; +end; + +(* parse an integer or real number. all digits up to the first non-digit are + already in curToken.tokenText. leaves the number on the stack. *) +(* FIXME: use getNumber *) +procedure parseNumber(last:TokenType;var typeReturn: TypeSpec); +var digits: KeywordString; + value: integer; + r: real; +begin + if last = MinusToken then + digits := '-' + curToken.tokenText + else + digits := curToken.tokenText; + + if not (peekChar in [ '.', 'E', 'e' ]) then + begin + value := integerFromString(digits); + emitLoadConstantInt(value); + setBaseType(typeReturn, IntegerType); + end + else + begin + if peekChar = '.' then (* is there a decimal point?*) + begin + digits := digits + nextChar; + if peekChar in [ '0'..'9'] then (* is there a fraction after the decimal point ? *) + begin + getDigits(nextChar, digits); + end; + end; + if peekChar in ['E','e'] then (* is there an exponent? *) + begin + digits := digits + nextChar; + + if peekChar in ['+', '-'] then (* exponent can have a sign *) + begin + digits := digits + nextChar; + end; + + if peekChar in ['0'..'9'] then (* now we require some exponent digits *) + begin + getDigits(nextChar, digits); + end + else + errorExit2('invalid number format', digits); + end; + r := realFromString(digits); + emitLoadConstantReal(r); + setBaseType(typeReturn, RealType); + end; + readNextToken; +end; + +procedure getToken(var tokenReturn:Token;stringTokens:boolean); +var curChar,pkChar: char; + keyword: KeywordString; + startLine: string[12]; +begin + curChar := nextChar; + + tokenReturn.tokenText := curChar; + + if curChar = #0 then + tokenReturn.tokenKind := EOFToken + else + if curChar = '+' then + tokenReturn.tokenKind := PlusToken + else + if curChar = '-' then + tokenReturn.tokenKind := MinusToken + else + if curChar = '*' then + begin + pkChar := peekChar; + if pkChar = ')' then + begin + skipChar; + tokenReturn.tokenText := tokenReturn.tokenText + pkChar; + tokenReturn.tokenKind := CommentAltEndToken; + end + else + tokenReturn.tokenKind := AsteriskToken; + end + else + if curChar = '/' then + tokenReturn.tokenKind := SlashToken + else + if curChar = '(' then + begin + pkChar := peekChar; + if pkChar = '*' then + begin + skipChar; + tokenReturn.tokenText := tokenReturn.tokenText + pkChar; + tokenReturn.tokenKind := CommentAltStartToken; + end + else + tokenReturn.tokenKind := LParenToken; + end + else + if curChar = ')' then + tokenReturn.tokenKind := RParenToken + else + if curChar = '{' then + tokenReturn.tokenKind := CommentStartToken + else + if curChar = '}' then + tokenReturn.tokenKind := CommentEndToken + else + if curChar = '[' then + tokenReturn.tokenKind := LBracketToken + else + if curChar = ']' then + tokenReturn.tokenKind := RBracketToken + else + if curChar = ',' then + tokenReturn.tokenKind := CommaToken + else + if curChar = '=' then + begin + pkChar := peekChar; + if pkChar = '=' then + begin + skipChar; + tokenReturn.tokenText := tokenReturn.tokenText + pkChar; + tokenReturn.tokenKind := EqEqToken; + end + else + tokenReturn.tokenKind := EqToken; + end + else + if curChar = '>' then + begin + pkChar := peekChar; + if pkChar = '=' then + begin + skipChar; + tokenReturn.tokenText := tokenReturn.tokenText + pkChar; + tokenReturn.tokenKind := GtEqToken; + end + else + tokenReturn.tokenKind := GtToken; + end + else + if curChar = '<' then + begin + pkChar := peekChar; + if pkChar = '=' then + begin + skipChar; + tokenReturn.tokenText := tokenReturn.tokenText + pkChar; + tokenReturn.tokenKind := LtEqToken; + end + else + if pkChar = '>' then + begin + skipChar; + tokenReturn.tokenText := tokenReturn.tokenText + pkChar; + tokenReturn.tokenKind := NotEqToken; + end + else + tokenReturn.tokenKind := LtToken; + end + else + if curChar = '.' then + begin + tokenReturn.tokenKind := DotToken; + end + else + if curChar = '^' then + begin + tokenReturn.tokenKind := PointerToken; + end + else + if curChar = ';' then + begin + tokenReturn.tokenKind := SemicolonToken; + end + else + if curChar = ':' then + begin + pkChar := peekChar; + if pkChar = '=' then + begin + skipChar; + tokenReturn.tokenText := tokenReturn.tokenText + pkChar; + tokenReturn.tokenKind := AssignmentToken; + end + else + tokenReturn.tokenKind := ColonToken; + end + else + if curChar in ['A'..'Z', 'a'..'z' ] then + begin + keyword := Upcase(curChar); + while peekChar in ['A'..'Z', 'a'..'z', '0'..'9', '_'] do + begin + curChar := Upcase(nextChar); + if (length(keyword) < 80) and (curChar <> #0) then keyword := keyword + curChar; + end; + tokenReturn.tokenText := keyword; + tokenReturn.tokenKind := findToken(keyword); + if tokenReturn.tokenKind = UnknownToken then tokenReturn.tokenKind := IdentToken; + end + else + if curChar in ['0'..'9' ] then + begin + keyword := ''; + getDigits(curChar, keyword); + tokenReturn.tokenText := keyword; + tokenReturn.tokenKind := NumberToken; + end + else + if curChar = '$' then + begin + keyword := ''; + getHexDigits(curChar, keyword); + tokenReturn.tokenText := keyword; + tokenReturn.tokenKind := NumberToken; + end + else + if (curChar = '''') and stringTokens then + begin + str(lineno, startLine); + keyword := ''; + curChar := nextChar; + (* add characters as long as the current char is not ' + (or if it is a double ') and not EOF *) + while (not ((curChar = '''') and (peekChar <> ''''))) and (curChar <> #0 ) do + begin + if (curChar = '''') and (peekChar = '''') then + begin + keyword := keyword + curChar; + curChar := nextChar; + end + else + keyword := keyword + curChar; + curChar := nextChar; + end; + if curChar = #0 then + errorExit2('Unterminated string constant starting at line', startLine); + tokenReturn.tokenText := keyword; + (* string literals with a length of 1 are char literals + which may be converted into string constants later *) + if length(keyword) = 1 then + tokenReturn.tokenKind := CharLitToken + else + tokenReturn.tokenKind := StringLitToken; + end + else + if curChar = '#' then + begin + tokenReturn.tokenText := chr(getInteger); + tokenReturn.tokenKind := CharLitToken; + end + else + tokenReturn.tokenKind := UnknownToken; +end; + +(* check for (and do not consume) a specific token, returns true on match *) +function checkToken(kind: TokenType): boolean; +begin + checkToken := curToken.tokenKind = kind; +end; + +(* move to next token without any processing. + sets curToken global variable. *) +procedure skipToNextToken; +begin + getToken(nextToken, true); + curToken := nextToken; +end; + +(* Parse a compiler directive which is inside a comment. + The start token of the comment has already been parsed. *) +procedure parseDirective(closingToken:TokenType); +var ch:char; + filename:string; +begin + ch := nextChar; (* skip $ character *) + ch := nextChar; (* this is our directive *) + if ch = 'I' then + begin + if peekChar = ' ' then + begin + readNextToken; + (* we require the include filename to be enclosed + in single quotes for simplicity *) + if curToken.tokenKind <> StringLitToken then + errorExit2('Include filename must be enclosed in single quotes',''); + filename := curToken.tokenText; + readNextToken; + if curToken.tokenKind <> closingToken then + errorExit2('Invalid directive', ''); + + beginInclude(filename); + matchToken(closingToken); + end + end + else + if ch = 'H' then + begin + if (peekChar = ' ') or isDigit(peekChar) then + begin + readNextToken; + defaultHeapSize := integerFromString(curToken.tokenText) * 1024; + readNextToken; + end; + matchToken(closingToken); + end + else + if ch = 'S' then + begin + if (peekChar = ' ') or isDigit(peekChar) then + begin + readNextToken; + defaultStackSize := integerFromString(curToken.tokenText) * 1024; + readNextToken; + end; + matchToken(closingToken); + end + else + if ch = '!' then + (* special comment till end of line *) + begin + while not (nextChar = #13) do (* nothing *); + readNextToken; + end + else + begin + (* no directive recognized, treat as comment *) + while not matchTokenOrNot(closingToken) do + begin + skipWhitespace; + skipToNextToken; + end; + end; +end; + +(* This will skip a comment, works with both comment styles depending + on closingToken. Also processes compiler directives. *) +procedure skipComment(closingToken: TokenType); +var startLine:string[8]; + done:boolean; +begin + if peekChar = '$' then + parseDirective(closingToken) + else + begin + str(lineno,startLine); + + if closingToken = CommentEndToken then + while nextChar <> '}' do + begin + if eof(infile) then + errorExit2('runaway comment starting at line', startLine); + end + else + if closingToken = CommentAltEndToken then + begin + done := false; + repeat + if eof(infile) then + errorExit2('runaway comment starting at line', startLine); + (* we cannot use getToken because it would not work with + string literals or numbers inside comments *) + if nextChar = '*' then + if peekChar = ')' then + done := nextChar = ')'; + until done; + end; + + skipWhitespace; + skipToNextToken; + end; +end; + +(* read the next token into the global variable curToken. + skips whitespace and comments. +*) +procedure readNextToken; +begin + skipWhitespace; + + lastToken := curToken; + getToken(nextToken, true); + curToken := nextToken; + + while curToken.tokenKind in [ CommentStartToken, CommentAltStartToken ] do + begin + if checkToken(CommentAltStartToken) then + skipComment(CommentAltEndToken) + else + if checkToken(CommentStartToken) then + skipComment(CommentEndToken) + end; +end; + +function checkComparisonOperator(aTokenType: TokenType): boolean; +begin + checkComparisonOperator := aTokenType in + [ LtToken, LtEqToken, EqToken, NotEqToken, GtEqToken, GtToken ]; +end; + +function getCompareOpFromToken(tok: TokenType): CompOpString; +begin + if not checkComparisonOperator(tok) then + errorExit2('invalid comparison operator token', ''); + case tok of + LtToken: getCompareOpFromToken := 'LT'; + LtEqToken: getCompareOpFromToken := 'LE'; + EqToken: getCompareOpFromToken := 'EQ'; + NotEqToken: getCompareOpFromToken := 'NE'; + GtEqToken: getCompareOpFromToken := 'GE'; + GtToken: getCompareOpFromToken := 'GT'; + end; +end; + +procedure cleanup; +begin + close(infile); + close(outfile); +end; + +procedure errorExit; +begin + cleanup; + halt; +end; + +procedure errorLine(line:integer); +begin + writeln('at line ',lineno, ' in ', filename); +end; + +procedure errorExit2(message1, message2: string); +var errormsg:string[128]; +begin + errormsg := message1 + ' ' + message2; + write(#13); ClrEol; + writeln('Error: ', errormsg); + errorLine(lineno); + if editOnError then + begin + cleanup; + ExecEditor(filename, lineno, errormsg) + end; + errorExit; +end; + +procedure errorExit1(message1:string); +begin + errorExit2(message1, ''); +end; + +function quoteToken(var s:string):string; +begin + if length(s) = 1 then + quoteToken := '''' + s + '''' + else + quoteToken := s; +end; + +(* match (and consume) a token or exit with error *) +procedure matchToken(kind: TokenType); +var errormsg:string[128]; +begin + if curToken.tokenKind <> kind then + begin + errormsg := 'Expected ' + quoteToken(keywords[kind]) + + ', got ' + quoteToken(curToken.tokenText); + errorExit1(errormsg); + end; + readNextToken; +end; + +(* match (and consume) a token, returning true, or if no match, do not + consume token and return false *) +function matchTokenOrNot(wantedToken: TokenType): boolean; +begin + if checkToken(wantedToken) then + begin + matchTokenOrNot := true; + readNextToken; + end + else + matchTokenOrNot := false; +end; + +(* like matchTokenOrNot, but does not return a value *) +procedure optionalToken(wantedToken: TokenType); +begin + if checkToken(wantedToken) then + readNextToken; +end; + +(* match a token. if the token is matched, consume it and return true. + if the current token is SemicolonToken, consume it and try to match the + next token then return true. + otherwise, return false and do not consume token. + Multiple consecutive semicolons are also matched and consumed. + + Example with tok1 = EndToken: + "; END" returns true + "; BEGIN" returns false + "END" returns true + "BEGIN" returns false + *) + + (* FIXME: the line reported in errors is now sometimes off by one, + because this function scans after a possible semicolon and into + the next line *) +function matchEndOf(tok1: TokenType): boolean; +begin + matchEndOf := false; + if (curToken.tokenKind = tok1) then + begin + matchEndOf := true; + readNextToken; + end + else + begin + while checkToken(SemicolonToken) do + readNextToken; + if matchTokenOrNot(tok1) then + matchEndOf := true + else + if curToken.tokenKind in [ EndToken, UntilToken, EOFToken ] then + errorExit2('Missing', quoteToken(keywords[tok1])) + end; +end; + +function getStringWordCount(maxLength:integer): integer; +begin + getStringWordCount := (maxLength + (wordSize - 1)) div wordSize; +end; + +function getStringMemSize(maxLength: integer): integer; +var size: integer; +begin + size := 2 * wordSize; + size := size + getStringWordCount(maxLength) * wordSize; + getStringMemSize := size; +end; + +procedure compareStrings(operatr: TokenType); +var compOp: CompOpString; +begin + compOp := getCompareOpFromToken(operatr); + if operatr = EqToken then + emitStringComparison + else if operatr = NotEqToken then + begin + emitStringComparison; + emitBooleanNot; + end + else + emitStringLexiComparison(compOp); +end; + +procedure compareAggregate(operatr: TokenType; var typ: TypeSpec); +begin + emitMemComparison(typ); + if operatr <> EqToken then + begin + if operatr = NotEqToken then + emitBooleanNot + else + errorExit2('Invalid comparison operator for aggregate type',''); + end; +end; + +(* Scan for an integer and return its value. nothing is placed on the stack. + Handles constant identifiers. + should be called getInteger then for consistency. + *) +function parseInteger: Integer; +var cnst: ConstRef; + digits: string[12]; +begin + (* handle possible constant *) + if checkToken(IdentToken) then + begin + cnst := findConstantHiera(curToken.tokenText); + if cnst = nil then + errorExit2('Number or constant identifier expected, got', + curToken.tokenText); + if cnst^.typ.baseType <> IntegerType then + errorExit2('Not an integer constant:', curToken.tokenText); + parseInteger := cnst^.intValue; + end + else + begin + digits := curToken.tokenText; + if matchTokenOrNot(MinusToken) then + begin + readNextToken; + digits := digits + curToken.tokenText; + end; + parseInteger := integerFromString(digits); + end; + readNextToken; +end; + +procedure parseConstant(var typeReturn: TypeSpec); +var intValue:integer; +begin + getRangePart(intValue, typeReturn); + emitLoadConstantInt(intValue); +end; + + +(* + write a value to a variable. + accessScalar or parseMemLocation must have been called + before, with the same symbol reference. + Subrange checks can be switched off, which is only used + in for-loop iterations. +*) +procedure writeVariable2(var mem: MemLocation; checkSubranges:boolean); +begin + if mem.typ.baseType in [ IntegerType, BooleanType, RealType, CharType, PointerType, + EnumType, SetType ] + then + begin + if mem.typ.hasSubrange and checkSubranges then + emitSubrangeCheck(mem.typ.subStart,mem.typ.subEnd); + case mem.memLoc of + Indirect: emitStoreIndirect; + GlobalMem: errorExit2('internal error: accessing GlobalMem', mem.name); + LocalMem: emitStoreLocal(mem.offset, mem.name); + NestedMem: emitStoreNested(mem.offset, mem.scopeDistance, mem.name); + end; + end + else if mem.typ.baseType = StringType then + emitCopyString + else if mem.typ.baseType in [ ArrayType, RecordType ] then + emitCopy(mem.typ.size) + else if mem.typ.baseType = StringCharType then + emitSetStringChar (* store char to byte ptr *) + else + errorExit2('internal error: writeVariable baseType not handled for', mem.name); +end; + + +(* + Write a value to a variable. + accessScalar or parseMemLocation must have been called + before, with the same symbol reference. + Subrange checks are enabled. + See writeVariable2. +*) + +procedure writeVariable(var mem:MemLocation); +begin + writeVariable2(mem, true); +end; + +(* + read value from a memory location. + see parseMemLocation which parses an identifier into a + memory location. + if it is an indirect access, the address has to be on the stack already. + this can be done with parseMemLocation or accessScalar. +*) +procedure readVariable(var mem: MemLocation); +begin + if mem.typ.baseType in [ IntegerType, BooleanType, RealType, CharType, PointerType, + EnumType, SetType ] then + begin + case mem.memLoc of + Indirect: emitLoadIndirect; + GlobalMem: errorExit2('internal error: accessing GlobalMem for', mem.name); + LocalMem: emitLoadLocal(mem.offset, mem.name); + NestedMem: emitLoadNested(mem.offset, mem.scopeDistance, mem.name); + end; + end + else if mem.typ.baseType = ArrayType then + (* nothing to do to access a whole array, its address + is already on the stack *) + else if mem.typ.baseType = StringType then + begin end + (* nothing to do to read a string variable, its + address is already on the stack *) + else if mem.typ.baseType = RecordType then + (* nothing to do to read a record variable, its + address is already on the stack *) + else if mem.typ.baseType = StringCharType then + begin + emitLoadStringChar; (* load char from byte ptr *) + setBaseType(mem.typ, CharType); (* we now have a char on stack *) + end + else + errorExit2('internal error: reading memloc', mem.name); +end; + +procedure convertToIndirect(var mem: MemLocation); +begin + if mem.memLoc <> Indirect then + begin + if mem.memLoc = GlobalMem then + emitLoadGlobalAddr(mem.name, mem.offset) + else if mem.memLoc = LocalMem then + emitLoadLocalAddr(mem.name, mem.offset) + else if mem.memLoc = NestedMem then + emitLoadNestedAddr(mem.name, mem.scopeDistance, mem.offset); + + setIndirect(mem); + end; +end; + +procedure addMemOffset(var mem: MemLocation; delta: integer); +begin + (* if the location is indirect, i.e. the address is already on stack, + we need to emit code for increasing the address. + otherwise, we just increase the offset *) + if mem.MemLoc in [ Indirect, OnStack ] then + emitInc(delta); + mem.offset := mem.offset + delta; +end; + +(* Parse possible qualifiers of a symbol down to a memory location. + This can be a scalar variable, an array element, or a record field. + Places the address on the stack if it is not a local variable. + This is called after the identifier has been parsed and the + symbol (SymblRef) has already been determined. + + "Qualifiers" are: Array indices(brackets), record field qualifiers, + pointer dereferencing (^ operator). + + ForceIndirect is (only?) used when passing var parameters. + The sym parameter can be nil if memReturn has already been + initialized. + + Scalar variables should resolve to GlobalMem with a symbol name + or to LocalMem with an offset. + Record fields should resolve to GlobalMem with symbol + offset + or LocalMem with cumulative offset. + If the MemLocType is already Indirect (e.g. array of record), + they address is already on stack. + Arrays of arrays or arrays as record fields should + calculate an offset as usual and add to address on stack. + *) + +(* TODO: rename to something like parseQualifiers *) +procedure parseSymMemLoc(sym:SymblRef;forceIndirect: boolean; var memReturn: MemLocation); +var aFieldRef: ^FieldListItem; + elementType: TypeSpec; + pointerMemLoc: MemLocation; +begin + if sym <> nil then + initMemLocation(sym, memReturn); + + while curToken.tokenKind in [ LBracketToken, DotToken, PointerToken ] do + begin + if checkToken(LBracketToken) then + begin + (* indexing an array *) + convertToIndirect(memReturn); + if memReturn.typ.baseType = ArrayType then + begin + parseArrayIndex(memReturn.typ, memReturn.name, elementType); + memReturn.typ := elementType; + + (* strings contained in arrays need to be initialized *) + if memReturn.typ.baseType = StringType then + memReturn.initialized := false; + end + else + if memReturn.typ.baseType = StringType then + begin + parseStringIndex; + memReturn.typ.baseType := StringCharType; + end + else + errorExit2('invalid subscript for', memReturn.name); + end + else if checkToken(DotToken) then + begin + (* accessing a record field *) + readNextToken; + aFieldRef := findField(memReturn.typ, curToken.tokenText); + if aFieldRef = nil then + errorExit2('invalid field name', curToken.tokenText); + readNextToken; + addMemOffset(memReturn, aFieldRef^.offset); + memReturn.typ := aFieldRef^.fieldType; + + (* strings contained in records need to be initialized *) + if memReturn.typ.baseType = StringType then + memReturn.initialized := false; + + { + if aFieldRef^.isVariant then + writeln('******* variant:', aFieldRef^.isVariant, + ' first case value:', aFieldRef^.tagValues.tail^.value); + } + end + else if checkToken(PointerToken) then + begin + (* dereferencing a pointer *) + readNextToken; + if memReturn.typ.baseType <> PointerType then + if sym <> nil then + errorExit2('not a pointer:', sym^.name) + else + errorExit2('not a pointer', ''); + + pointerMemLoc := memReturn; + + convertToIndirect(memReturn); + + memReturn.typ := memReturn.typ.pointedType^; + memReturn.initialized := true; + (* assume that the variable the pointer points to + is initialized. otherwise, passing a pointer to + a string would overwrite the string header with + wrong values, if the string lengths + of the argument and the parameter differ *) + + (* Function return values are encoded as NoMem, + which means the value (not the address of the pointer) + is already on stack. In this case, + we need to skip the emitLoadIndirect. *) + if pointerMemLoc.memLoc <> OnStack then + emitLoadIndirect; (* the pointer variable contains the address *) + end; + end; + + if (memReturn.typ.baseType in [StringType, RecordType, ArrayType ]) + or forceIndirect or + (memReturn.memLoc = GlobalMem) then + convertToIndirect(memReturn); +end; + +(* parse an identifier and possible qualifiers, see parseSymMemLoc() *) +procedure parseMemLocation(forceIndirect: boolean; var memReturn: MemLocation); +var sym: SymblRef; +begin + if curToken.tokenKind <> IdentToken then + errorExit2('Expected identifier, got', curToken.tokenText); + sym := findHieraSymbol(curToken.tokenText); + if sym = nil then + errorExit2('Undeclared variable', curToken.tokenText); + readNextToken; + parseSymMemLoc(sym, forceIndirect, memReturn); +end; + +procedure loadAddr(var loc: MemLocation); +begin + case loc.memLoc of + GlobalMem: emitLoadGlobalAddr(loc.name, loc.offset); + LocalMem: emitLoadLocalAddr(loc.name, loc.offset); + NestedMem: emitLoadNestedAddr(loc.name, loc.scopeDistance, loc.offset); + Indirect: errorExit2('internal error: loadAddr with Indirect', loc.name); + TemporaryMem: emitLoadTempAddr(loc.name, loc.offset); + end; +end; + +(* load the pointer/reference of a local or nested var parameter *) +procedure loadVarParamRef(var loc: MemLocation); +begin + if loc.memLoc = LocalMem then + emitLoadLocal(loc.offset, loc.name) + else + if loc.memLoc = NestedMem then + emitLoadNested(loc.offset, loc.scopeDistance, + loc.name) + else + errorExit2('internal error in loadVarParamRef',''); +end; + +(* calculate the address for a variable that fits into one word. + code is emitted to put the address on the stack, if it is not + a short access. a MemLocation record is returned which can + be passed to readVariable/writeVariable for the actual access. +*) +procedure accessScalar(sym: SymblRef; var memLocReturn: MemLocation); +begin + initMemLocation(sym, memLocReturn); + if sym^.scope = GlobalSymbol then + begin + convertToIndirect(memLocReturn); + end + else if (sym^.scope in [ LocalSymbol, ParameterSymbol ]) and sym^.isVarParam then + (* for var parameters the local variable slot contains + the address of the value, so we do a emitLoad... not a + emitLoad...Addr *) + loadVarParamRef(memLocReturn) + else + begin + if memLocReturn.memLoc = LocalMem then + emitLocalMemLoc(memLocReturn) + else if memLocReturn.memLoc = NestedMem then + emitNestedMemLoc(memLocReturn); + end; +end; + +procedure accessVariable(sym: SymblRef; var memLocReturn: MemLocation); +begin + accessScalar(sym, memLocReturn); + if not isScalar(sym^.symType) then + convertToIndirect(memLocReturn); +end; + +procedure dumpVars(var table: SymbolTable); +var sym: SymblRef; +begin + writeln('dumpVars ', table.scope); + sym := table.first; + while sym <> nil do + begin + writeln(' ', sym^.name, ' ', sym^.symType.baseType); + end; +end; + +(* the pointer to the string is already on the stack here *) +procedure parseStringIndex; +var typeReturn: TypeSpec; +begin + matchToken(LBracketToken); + parseExpression(typeReturn); (* now we have the string ptr and index value on stack*) + matchBaseType(typeReturn, IntegerType); + emitStringIndexToAddr; + matchToken(RBracketToken); +end; + +procedure parseArrayIndex(var arrayTyp: TypeSpec; var name: IdentString;var elType:TypeSpec); +var typeReturn: TypeSpec; +begin + elType := arrayTyp; + matchToken(LBracketToken); + repeat + parseExpression(typeReturn); + if typeReturn.baseType = EnumType then + begin + if arrayTyp.indexEnumId = 0 then + errorExit2('invalid array subscript type for', name); + if typeReturn.enumId <> arrayTyp.indexEnumId then + errorExit2('invalid array subscript type for', name) + end + else + if not isIndexType(typeReturn) then + errorExit2('invalid array subscript type for', name); + + emitIndexToAddr(elType); + + elType := elType.elementType^; + + if checkToken(CommaToken) then + begin + if elType.baseType <> ArrayType then + errorExit2('invalid array subscript for', name) + end; + until not matchTokenOrNot(CommaToken); + matchToken(RBracketToken); +end; + +(* parse accessing an array constant. + merge this with parseMemLocation? *) +procedure parseArrayConstAccess(cnst:ConstRef; var returnType:TypeSpec); +begin + emitLoadArrayConst(cnst^.arrayValue); + if checkToken(LBracketToken) then + begin + parseArrayIndex(cnst^.typ, cnst^.name, returnType); + emitLoadIndirect; + end +end; + +procedure parseVarBlock; forward; + +procedure parseCall(aProc: ProcRef; var optionalDest: MemLocation); forward; + +(* Parse an identifier as part of an expression. also parses array indices, + record fields and pointer dereferencing. + See also parseLvalue which parses an identifier as the left hand side + of an assignment. + Emits code to place the result value on the eval stack. + *) +procedure parseIdentifier(var returnType: TypeSpec); +var sym: SymblRef; + cnst: ConstRef; + func: ProcRef; + memLoc: MemLocation; + sf: SpecialFunc; + name:IdentString; + isCall:boolean; +begin + name := curToken.tokenText; + readNextToken; + + cnst := findConstantHiera(name); + if cnst <> nil then + begin + returnType := cnst^.typ; + case cnst^.typ.baseType of + IntegerType, CharType, BooleanType: + emitLoadConstantInt(cnst^.intValue); + RealType: + emitLoadConstantReal(cnst^.realValue); + ArrayType: + parseArrayConstAccess(cnst, returnType); + StringType: + emitLoadConstStr(cnst^.strValue); + EnumType: + begin + emitLoadConstantInt(cnst^.intValue); + returnType := cnst^.enumRef^.typePtr^; + end + else + errorExit2('internal error in parseIdentifier constant',cnst^.name); + end; + end + else + begin + (* function call syntax? *) + isCall := checkToken(LParenToken); + (* is it a variable?*) + sym := findHieraSymbol(name); + if isCall or (sym = nil) then + begin + (* if no symbol found, or if we have parentheses, + it must be a function *) + func := searchProcedure(name); + if func = nil then + begin + sf := findSpecialFunction(name); + if sf <> NoSF then + parseSpecialFunction(sf, returnType) + else + errorExit2('Undeclared identifier', name) + end + else + begin + if not isFunction(func) then + errorExit2('procedure cannot be called as a function:', name) + else + begin + initNoMemLocation(memLoc); + parseCall(func, memLoc); + returnType := func^.returnType; + (* a function return value can have qualifiers like array + indexing or pointer dereferencing, so try to parse them *) + (* TODO: redundant code with parseSymMemLoc, at least + make a checkQualifierToken() function *) + + if curToken.tokenKind in [ LBracketToken, DotToken, PointerToken] then + begin + memLoc.typ := func^.returnType; + (* address is already on stack, so the memloc type is OnStack *) + memLoc.memLoc := OnStack; + parseSymMemLoc(nil, false, memLoc); + readVariable(memLoc); + returnType := memLoc.typ; + end; + end + end + end + else + begin + (* we found a sym, so it is a variable *) + parseSymMemLoc(sym, false, memLoc); + readVariable(memLoc); + returnType := memLoc.typ; + { + if returnType.baseType = SetType then + writeln('********** parseIdentifier Set var enum id ', returnType.memberEnumId); + } + + end; + end; +end; + +procedure parseLvalue(var memLocReturn: MemLocation); +begin + parseMemLocation(false, memLocReturn); +end; + +procedure parsePrimary(var typeReturn: TypeSpec); +var c:ConstStrRef; +begin + if checkToken(LParenToken) then + begin + readNextToken; + parseExpression(typeReturn); + matchToken(RParenToken); + end + else + if checkToken(NumberToken) then + begin + (* parse integer and real *) + parseNumber(PlusToken, typeReturn); + end + else + if checkToken(IdentToken) then + begin + parseIdentifier(typeReturn); + end + else + if checkToken(StringLitToken) then + begin + c := addConstStr(curToken.tokenText); + emitLoadConstStr(c); + setStringTypeSize(typeReturn, c^.length); + readNextToken; + end + else + if checkToken(TrueToken) then + begin + emitConstBoolean(true); + setBaseType(typeReturn, BooleanType); + readNextToken; + end + else + if checkToken(FalseToken) then + begin + emitConstBoolean(false); + setBaseType(typeReturn, BooleanType); + readNextToken; + end + else + if checkToken(NilToken) then + begin + emitLoadConstantInt(0); + setBaseType(typeReturn, PointerType); + typeReturn.pointedType := nil; + readNextToken; + end + else + if checkToken(CharLitToken) then + begin + (* TODO: convert to string constant if destination is string *) + emitLoadConstantInt(getCharLitValue(curToken.tokenText)); + setBaseType(typeReturn, CharType); + readNextToken; + end + else + errorExit2('Unexpected token ', quoteToken(curToken.tokenText)); +end; + +procedure parseUnary(var typeReturn: TypeSpec); +begin + if checkToken(PlusToken) then + begin + readNextToken; + parsePrimary(typeReturn); + if not (typeReturn.baseType in [IntegerType, RealType]) then + errorExit2('Expected INTEGER or REAL type for unary','+') + end + else + if checkToken(MinusToken) then + begin + readNextToken; + if checkToken(NumberToken) then + parseNumber(MinusToken, typeReturn) + else + begin + parsePrimary(typeReturn); + if typeReturn.baseType = IntegerType then + emitNegate + else if typeReturn.baseType = RealType then + emitNegFloat32; + end; + + if not (typeReturn.baseType in [ IntegerType, RealType]) then + errorExit2('Expected INTEGER or REAL type for unary','-'); + end + else + if checkToken(NotToken) then + begin + readNextToken; + parsePrimary(typeReturn); + if typeReturn.baseType = BooleanType then + emitBooleanNot + else + if typeReturn.baseType = IntegerType then + emitNot + else + errorExit2('Boolean or integer operand expected', ''); + end + else + parsePrimary(typeReturn); +end; + +procedure shiftIntegerOp(var typeA, typeB: TypeSpec; op: string); +begin + matchBaseTypes(typeA, typeB, IntegerType); + emitShiftMultiple(op); +end; + +procedure integerOp(var typeA, typeB: TypeSpec; op: string); +begin + matchBaseTypes(typeA, typeB, IntegerType); + emitOperator(op); +end; + +procedure realOp(var typeA, typeB: TypeSpec; op: string); +begin + matchRealCompatibleArgs(typeA, typeB); + emitFloatOperator(op); +end; + +procedure arithmeticOp(var typeA, typeB: TypeSpec; op: string); +begin + if (typeA.baseType = RealType) or (typeB.baseType = RealType) then + realOp(typeA, typeB, op) + else + integerOp(typeA, typeB, op); +end; + +procedure logicOp(var typeA, typeB: TypeSpec; op: string); +begin + matchLogicOpTypes(typeA, typeB); + emitOperator(op); +end; + +procedure parseTerm(var typeReturn: TypeSpec); +var operatr: TokenType; + typeA, typeB: TypeSpec; +begin + typeA := typeReturn; + typeB := typeReturn; + parseUnary(typeA); (* parse first operand *) + + (* ugly hack for set expressions *) + if typeA.baseType = SetType then + parseSetExprTail(typeA) + else + begin + while curToken.tokenKind in [AsteriskToken, DivToken, ModToken, SlashToken, + AndToken, ShrToken, ShlToken ] do + begin + operatr := curToken.tokenKind; + readNextToken; + (* / check first operand for real type, realOp checks second operand *) + if operatr = SlashToken then matchRealType(typeA); + parseUnary(typeB); (* parse second operand *) + if operatr = AsteriskToken then arithmeticOp(typeA, typeB, 'MUL') + else if operatr = DivToken then arithmeticOp(typeA, typeB, 'DIV') + else if operatr = ModToken then arithmeticOp(typeA, typeB, 'MOD') + else if operatr = ShlToken then shiftIntegerOp(typeA, typeB, 'SHLM') + else if operatr = ShrToken then shiftIntegerOp(typeA, typeB, 'SHRM') + else if operatr = SlashToken then realOp(typeA, typeB, 'DIV') + else if operatr = AndToken then logicOp(typeA, typeB, 'AND'); + end; + end; + typeReturn := typeA; +end; + +procedure dumpArrayConst(a:ArrayConstRef); +var curElem: ^OpaqueDataElement; +begin + curElem := a^.firstElement; + writeln('**** dumpArrayConst id ', a^.id); + write('**** dumpArrayConst [ '); + while curElem <> nil do + begin + if curElem^.isStringValue then + write(curElem^.strValue^) + else + write(curElem^.intValue,' '); + curElem := curElem^.next; + end; + writeln(']'); +end; + +function getCharValue:integer; +var cons: ConstRef; +begin + if checkToken(IdentToken) then + begin + cons := findConstantHiera(curToken.tokenText); + if cons = nil then + errorExit2('invalid character constant', curToken.tokenText); + matchBaseType(cons^.typ, CharType); + getCharValue := cons^.intValue; + readNextToken; + end + else + begin + matchToken(CharLitToken); + getCharValue := ord(lastToken.tokenText[1]); + end; +end; + +procedure parseCharConstArray(arrayConst:ArrayConstRef); +var count: integer; + value: integer; + startValue,endValue: integer; +begin + count := 0; + + while curToken.tokenKind in [CharLitToken, IdentToken] do + begin + startValue := getCharValue; + endValue := startValue; + (* process a subrange specification *) + if checkToken(DotToken) then + begin + readNextToken; + if not matchTokenOrNot(DotToken) then + errorExit2('invalid subrange spec after', lastToken.tokenText); + endValue := getCharValue; + end; + + for value := startValue to endValue do + begin + count := count + 1; + addArrayConstElem(arrayConst, value); + end; + + if checkToken(CommaToken) then + begin + readNextToken; + if not (curToken.tokenKind in [CharLitToken, IdentToken]) then + errorExit2('char literal or constant expected, got', curToken.tokenText); + end; + end; + arrayConst^.count := count; +end; + +(* TODO: merge with parseCharConstArray? *) +(* TODO: reuse parseArrayLitValue, parseConstValue, getConstvalue? *) +procedure parseIntConstArray(arrayConst:ArrayConstRef); +var count: integer; + value: integer; + startValue, endValue: integer; +begin + count := 0; + while curToken.tokenKind in [NumberToken, IdentToken] do + begin + startValue := parseInteger; + endValue := startValue; + (* process a subrange specification *) + if checkToken(DotToken) then + begin + readNextToken; + if not matchTokenOrNot(DotToken) then + errorExit2('invalid subrange spec after', lastToken.tokenText); + endValue := parseInteger; + end; + + for value := startValue to endValue do + begin + count := count + 1; + addArrayConstElem(arrayConst, value); + end; + + if checkToken(CommaToken) then + begin + readNextToken; + if not (curToken.tokenKind in [NumberToken, IdentToken]) then + errorExit2('integer literal or constant expected, got', curToken.tokenText); + end + end; + arrayConst^.count := count; +end; + +function getBooleanValue:boolean; +begin + if checkToken(TrueToken) then + getBooleanValue := true + else if checkToken(FalseToken) then + getBooleanValue := false + else + errorExit2('Expected TRUE or FALSE, got', curToken.tokenText); + readNextToken; +end; + +procedure getRangePart(var value:integer; var typeReturn: TypeSpec); +var cnst: ConstRef; +begin + setBaseType(typeReturn, NoType); + + if checkToken(IdentToken) then + begin + (* is it a constant ? *) + cnst := findConstantHiera(curToken.tokenText); + if cnst <> nil then + begin + typeReturn := cnst^.typ; + if cnst^.typ.baseType in [IntegerType, EnumType, CharType ] then + value := cnst^.intValue + else + errorExit2('scalar value or constant identifier expected, got', + curToken.tokenText); + end + else + errorExit2('scalar value or constant identifier expected, got', + curToken.tokenText); + readNextToken; + end + else if checkToken(CharLitToken) then + begin + setBaseType(typeReturn, CharType); + value := ord(curToken.tokenText[1]); + readNextToken; + end + else if checkToken(TrueToken) or checkToken(FalseToken) then + begin + setBaseType(typeReturn, BooleanType); + value := ord(getBooleanValue); + end + else + begin + setBaseType(typeReturn, IntegerType); + value := parseInteger; + end; +end; + +(* TODO: merge with parseCharConstArray? *) +procedure parseEnumConstArray(arrayConst:ArrayConstRef); +var count: integer; + value: integer; + startValue, endValue: integer; + typeA, typeB: TypeSpec; +begin + count := 0; + while checkToken(IdentToken) do + begin + getRangePart(startValue, typeA); + endValue := startValue; + + (* process a subrange specification *) + if checkToken(DotToken) then + begin + readNextToken; + if not matchTokenOrNot(DotToken) then + errorExit2('invalid subrange spec after', lastToken.tokenText); + getRangePart(endValue, typeB) + end; + + for value := startValue to endValue do + begin + count := count + 1; + addArrayConstElem(arrayConst, value); + end; + + if checkToken(CommaToken) then + begin + readNextToken; + if not checkToken(IdentToken) then + errorExit2('integer literal or constant expected, got', curToken.tokenText); + end + end; + arrayConst^.count := count; +end; + +(* parse and convert an array literal without the brackets *) +function getArrayConstRaw(var typeReturn: TypeSpec): ArrayConstRef; +var newArrayConst: ArrayConstRef; + newArrayType:^TypeSpec; + cons: ConstRef; + baseType: SymbolType; +begin + setBaseType(typeReturn, ArrayType); + + newArrayConst := addArrayConst; + + new(newArrayType); + + (* check for symbolic constant to determine type *) + if checkToken(IdentToken) then + begin + cons := findConstantHiera(curToken.tokenText); + if cons = nil then + errorExit2('invalid element identifier', curToken.tokenText); + baseType := cons^.typ.baseType; + case baseType of + IntegerType: parseIntConstArray(newArrayConst); + CharType: parseCharConstArray(newArrayConst); + EnumType: parseEnumConstArray(newArrayConst); + else + errorExit2('element must be of integer, char or enum type:', curToken.tokenText); + end; + newArrayType^ := cons^.typ; + end + else if checkToken(CharLitToken) then + begin + setBaseType(newArrayType^, CharType); + parseCharConstArray(newArrayConst); + end + else if checkToken(NumberToken) then + begin + setBaseType(newArrayType^, IntegerType); (* TODO: handle real numbers *) + parseIntConstArray(newArrayConst); + end + else + errorExit2('invalid set/array literal at', curToken.tokenText); + + typeReturn.arrayLength := newArrayConst^.count; + typeReturn.arrayStart := 1; + typeReturn.arrayEnd := typeReturn.arrayLength; + typeReturn.elementType := newArrayType; + typeReturn.size := typeReturn.elementType^.size * typeReturn.arrayLength; + + { dumpArrayConst(newArrayConst); } + + getArrayConstRaw := newArrayConst; +end; + +(* parse and convert an array literal including the brackets *) +function getArrayConst(var typeReturn: TypeSpec): ArrayConstRef; +begin + matchToken(LBracketToken); + getArrayConst := getArrayConstRaw(typeReturn); + matchToken(RBracketToken); +end; + +procedure dumpEnumById(enumId:integer); +var typRef: TypeRef; + names: StringList; + name: IdentString; +begin + typRef := findEnumById(enumId); + if typRef = nil then + writeln('enum id ', enumId, ' not found') + else + begin + names := typRef^.typePtr^.enumList; + rewindStringList(names); + while(nextStringListItem(names, name)) do write(name, ' '); + writeln; + end; +end; + +(* we handle that what is syntactically a set literal in + standard pascal as an array literal. <- Should be called + "parseArrayLiteral" then. + Real set literals are parsed in parseSetTerm/parseSetExpression *) +procedure parseSetLiteral(var typeReturn: TypeSpec); +var newArrayConst: ArrayConstRef; +begin + newArrayConst := getArrayConst(typeReturn); + emitLoadArrayConst(newArrayConst); +end; + +(* parse some comma-separated set items without the brackets *) +procedure parseSetValue(var elementType: TypeSpec); +var sym:SymblRef; + cnst: ConstRef; + savedType: TypeSpec; +begin + (* we don't know the type at first *) + setBaseType(savedType, NoType); + (* start with an empty set value on the stack, + then set bits below *) + emitLoadConstantInt(0); + repeat + if checkToken(IdentToken) + then + begin + (* is it a variable? *) + sym := findHieraSymbol(curToken.tokenText); + if sym <> nil then + begin + parseIdentifier(elementType); + if savedType.baseType = NoType then + savedType := elementType; + end + else + begin + (* if not, it should be a constant *) + cnst := findConstantHiera(curToken.tokenText); + if cnst = nil then + errorExit2('Integer constant or variable expected, got', + curToken.tokenText); + elementType := cnst^.enumRef^.typePtr^; + if savedType.baseType = NoType then + savedType := elementType; + emitLoadConstantInt(cnst^.intValue); + end; + emitAddToSet; + readNextToken; + end + else if checkToken(NumberToken) then + begin + errorExit2('Integers in sets not implemented yet', + curToken.tokenText); + end + else if checkToken(RBracketToken) then + begin + (* empty set is permissible *) + end + else + errorExit2('Integer constant or variable expected, got', + curToken.tokenText); + + if savedType.baseType <> NoType then + matchTypes(savedType, elementType); + + until not matchTokenOrNot(CommaToken); +end; + +procedure parseSetTerm(var setTypeReturn: TypeSpec); +var typ:TypeSpec; + elementType:TypeSpec; +begin + if checkToken(LBracketToken) then + begin + (* handle a set literal *) + readNextToken; + parseSetValue(elementType); + matchToken(RBracketToken); + setBaseType(setTypeReturn, SetType); + setTypeReturn.memberBaseType := elementType.baseType; + if elementType.baseType = EnumType then + setTypeReturn.memberEnumId := elementType.enumId; + setTypeReturn.hasSubrange := elementType.hasSubrange; + setTypeReturn.subStart := elementType.subStart; + setTypeReturn.subEnd := elementType.subEnd; + end + else + if checkToken(IdentToken) then + begin + (* handle a set variable *) + parseIdentifier(typ); + matchBaseType(typ, SetType); + setTypeReturn := typ; + end + else + errorExit2('rest of parseSetTerm not implemented yet', + curToken.tokenText); +end; + +(* Parse second part of a set expression. + typeA needs to be set to the set type (not the member type). + Valid operators are: +, -, *, =, <>, <= + *) + +procedure parseSetExprTail(var typeA: TypeSpec); +var tok:TokenType; + typeB: TypeSpec; +begin + tok := curToken.tokenKind; + + while tok in [ PlusToken, MinusToken, AsteriskToken, + EqToken, NotEqToken, LtEqToken, GtEqToken] do + begin + readNextToken; + parseSetTerm(typeB); + { + dumpEnumById(typeA.memberEnumId); + dumpEnumById(typeB.memberEnumId); + } + matchTypes(typeA, typeB); + + case tok of + PlusToken: emitSetAdd; + MinusToken: emitSetSubtract; + AsteriskToken: emitSetIntersect; + EqToken: emitSetCompare; + NotEqToken: emitSetCompareNE; + LtEqToken: emitSetIsSubset; + GtEqToken: begin emitSwap; emitSetIsSubset; end; + end; + + tok := curToken.tokenKind; + end; +end; + +(* Parse a set expression (which may be a single term), return + the type in typeReturn *) +procedure parseSetExpression(var typeReturn: TypeSpec); +var elementType:TypeSpec; +begin + parseSetTerm(elementType); + setBaseType(typeReturn, SetType); + typeReturn.memberBaseType := elementType.baseType; + if typeReturn.memberBaseType = EnumType then + typeReturn.memberEnumId := elementType.enumId; + typeReturn.hasSubrange := elementType.hasSubrange; + typeReturn.subStart := elementType.subStart; + typeReturn.subEnd := elementType.subEnd; + parseSetExprTail(typeReturn); +end; + +procedure parseInOperator(var typeA: TypeSpec); +var typeB: TypeSpec; +begin + if not isSimpleType(typeA) then + errorExit2('invalid IN operand*', lastToken.tokenText); + + matchToken(InToken); + parseExpression(typeB); + if (typeB.baseType = ArrayType) then + begin + { + writeln('**** parseInOperator types ', + typeA.baseType, ' -> ', typeB.elementType^.baseType); + if typeA.baseType = EnumType then + writeln(' enum types ', typeA.enumId, ' ', typeB.elementType^.enumId); + } + matchTypes(typeA, typeB.elementType^); + emitIsInArray(typeB.arrayLength); + end + else + if typeB.baseType = SetType then + begin + matchBaseType(typeA, typeB.memberBaseType); + if (typeB.memberBaseType = EnumType) and + (typeA.enumId <> typeB.memberEnumId) then + errorExit2('Invalid IN operand', lastToken.tokenText); + emitIsInSet; + end + else + if typeB.baseType = StringType then + begin + if not (typeA.baseType in [ CharType, StringCharType ]) then + errorExit2('Invalid IN operand before', lastToken.tokenText); + emitIsInString; + end + else + errorExit2('invalid IN operand', lastToken.tokenText); +end; + +procedure parseSimpleExpression(var typeReturn: TypeSpec); +var operatr: TokenType; + typeA, typeB: TypeSpec; +begin + if checkToken(LBracketToken) then + parseSetLiteral(typeReturn) + else + begin + parseTerm(typeA); + (* special cases for char and string expressions *) + if typeA.baseType = CharType then + parseCharExprTail(typeA) + else + if typeA.baseType = StringType then + parseStringExprTail(typeA) + else + begin + while curToken.tokenKind in [PlusToken, MinusToken, OrToken, XorToken ] do + begin + operatr := curToken.tokenKind; + readNextToken; + parseTerm(typeB); + if operatr = PlusToken then arithmeticOp(typeA, typeB, 'ADD') + else if operatr = MinusToken then arithmeticOp(typeA, typeB, 'SUB') + else if operatr = OrToken then logicOp(typeA, typeB, 'OR') + else if operatr = XorToken then logicOp(typeA, typeB, 'XOR'); + end; + end; + typeReturn := typeA; + end; +end; + +(* Parse an expression. The value of the expression is placed on the stack. + The type is returned in typeReturn. + In case of an aggregate type, a temporary is allocated and the address + is placed on the stack *) +procedure parseExpression(var typeReturn: TypeSpec); +var operatr: TokenType; + typeA, typeB: TypeSpec; + compOp: CompOpString; +begin + parseSimpleExpression(typeA); + typeReturn := typeA; + if checkToken(InToken) then + begin + parseInOperator(typeA); + setBaseType(typeReturn, BooleanType); + end + else + if checkComparisonOperator(curToken.tokenKind) then + begin + operatr := curToken.tokenKind; + compOp := getCompareOpFromToken(operatr); + readNextToken; + parseSimpleExpression(typeB); + matchComparableTypes(typeA, typeB); + setBaseType(typeReturn, BooleanType); + if typeA.baseType = RealType then + begin + matchRealType(typeB); (* converts b from int to real if necessary *) + emitFloatComparison(compOp); + end + else if (typeA.baseType = IntegerType) and (typeB.baseType = RealType) then + begin + (* special case for comparing integer to real *) + emitIntFloatComparison(compOp); + end + else if isScalar(typeA) then + begin + emitComparison(compOp); + end + else + begin + if typeA.baseType = StringType then + compareStrings(operatr) + else + compareAggregate(operatr, typeA); + end; + end; +end; + +procedure parseStringPrimary; +var aConstStr: ConstStrRef; + typeReturn: TypeSpec; +begin + if checkToken(StringLitToken) or checkToken(CharLitToken) then + begin + aConstStr := addConstStr(curToken.tokenText); + emitLoadConstStr(aConstStr); + readNextToken; + end + else if checkToken(IdentToken) then + begin + parseIdentifier(typeReturn); + if typeReturn.baseType = CharType then + convertCharToString(typeReturn); + matchBaseType(typeReturn, StringType); + end + else + errorExit2('Expected string, got', curToken.tokenText); +end; + +(* Emit a copy or initfrom call, depending on the + initialization flag of the MemLocation. + We cannot always initialize strings on assignment, + as this would corrupt var parameters or + dereferenced string pointers. + We use the initialized field of Symbl and MemLocation + to track if a string has already been initialized. + *) +procedure initOrCopyString(var dstMem: MemLocation); +begin + if dstMem.initialized then + emitCopyString + else + emitInitStringFrom(dstMem.typ.stringLength); +end; + +(* allocate a temporary and initialize it from the + string pointer on the stack, which is then removed.*) +procedure getTempFromString(srcType:TypeSpec; var tempReturn: MemLocation); +var typ:TypeSpec; +begin + typ := srcType; + if typ.stringLength < DefaultStringLength then + setStringTypeSize(typ, DefaultStringLength); + + allocTemporary(curProcedure, typ, tempReturn); + loadAddr(tempReturn); (* put address of temporary on stack *) + emitSwap; (* and swap it with src for COPYSTRING *) + initOrCopyString(tempReturn); (* copy src to temp *) +end; + +(* convert a string to a temporary. + allocate temp space and copy source to temp. + requires src string address on stack, + which is then replaced by the address of the temporary *) +procedure convertStringToTemp(srcType:TypeSpec; var tempReturn: MemLocation); +begin + getTempFromString(srcType, tempReturn); + emitLoadTempAddr(tempReturn.name, tempReturn.offset); +end; + +(* parse the tail of a string expression, that is + everything after a plus operator if there is one + (including the plus operator) *) +procedure parseStringExprTail(dstType: TypeSpec); +var temp: MemLocation; +begin + if checkToken(PlusToken) then + begin + (* if there is a plus operator, we need to allocate a + temporary to build the concatenated string which is + then copied to the destination. this is required + so that it is possible to have the same string variable + on the left and the right side of the assignment. + example: s := '/' + s + *) + getTempFromString(dstType, temp); + while checkToken(PlusToken) do + begin + readNextToken; + emitLoadTempAddr(temp.name, temp.offset); + parseStringPrimary; + emitAppendString; + end; + (* put temporary address on stack as src for final COPYSTRING call *) + emitLoadTempAddr(temp.name, temp.offset); + end; +end; + +(* parse a string expression, which can be a single string identifier/literal or + a concatenation with a plus operator *) +procedure parseStringExpression(var dstMem: MemLocation); +begin + parseStringPrimary; (* parse first primary, addr is placed on stack *) + parseStringExprTail(dstMem.typ); (* parse the rest, if any *) + initOrCopyString(dstMem); (* copy to destination *) +end; + +(* parse the tail of a char expression, which can be a "+" operator, + making it a string expression, or an IN operator *) +procedure parseCharExprTail(var typeA: TypeSpec); +begin + if checkToken(PlusToken) then + begin + convertCharToString(typeA); + parseStringExprTail(typeA); + end + else + if checkToken(InToken) then + begin + parseInOperator(typeA); + setBaseType(typeA, BooleanType); + end; +end; + +procedure parseCompoundStatement; +begin + if checkToken(BeginToken) then + begin + readNextToken; + while not checkToken(EndToken) do + begin + parseStatement; + if not checkToken(EndToken) then + matchToken(SemicolonToken); + end; + matchToken(EndToken); + end + else + parseStatement; +end; + +(* Parse a range specification in the form 1..10. + Handles constants, enums, subrange types. + In case of an enum, the type is returned in typeReturn. + Otherwise, typeReturn is set to NoType. + For enum and subrange types, a single type identifier stands + for the start and the end value, like so: + type aSubrangeType = 1..10; + type anEnum = (one, two, three); + var anArray: array [aSubrangeType] of boolean; + var array2: array [anEnum] of boolean; + + Cases to cover: + 1..10 -> returns integer type with subrange + 1..c -> " + c..10 -> " + c1..c2 -> " + enum-type -> returns enum type + enumval1..enumval2 -> returns enum type + subrange-type -> returns enum type + *) +procedure getRange(var typeReturn:TypeSpec); +var typ,typ2: TypeSpec; + need2nd: boolean; + rStart,rEnd: integer; +begin + need2nd := true; + setBaseType(typeReturn, NoType); + setBaseType(typ, NoType); + setBaseType(typ2, NoType); + + if checkToken(IdentToken) then + begin + (* is it a enum or subrange type identifier? *) + typ := findTypeHiera(curToken.tokenText); + if typ.baseType <> NoType then + begin + readNextToken; + need2nd := false; + if typ.baseType = EnumType then + begin + setSubrange(typ, 0, typ.enumLength - 1); + typeReturn := typ; + end + else + if (typ.baseType = IntegerType) and (typ.hasSubrange) then + begin + typeReturn := typ; + end + (* TODO: can also be a set type identifier *) + else + errorExit2('invalid range specification', curToken.tokenText); + end + else + (* should be a constant now, maybe with an enum type *) + getRangePart(rStart, typ); + end + else if curToken.tokenKind in [ NumberToken, MinusToken, CharLitToken ] then + begin + (* integer and char can also be handled by getRangePart *) + getRangePart(rStart, typ); + end + else + errorExit2('invalid range specification', curToken.tokenText); + + if need2nd then + begin + matchToken(DotToken); + matchToken(DotToken); + + getRangePart(rEnd,typ2); + + if typ.baseType <> typ2.baseType then + errorExit2('invalid range specification', lastToken.tokenText); + + if rStart > rEnd then + errorExit2('range start must be less than end', lastToken.tokenText); + + typeReturn := typ; + setSubrange(typeReturn, rStart, rEnd); + end; +end; + +procedure parseRangeSpec(var typeReturn:TypeSpec); +begin + getRange(typeReturn); +end; + +(* Parse the range part of an array declaration and try to determine + the element type. + When handling multiple array dimensions, + parseArraySpecPart is called recusively for each part + (like "1..10,1..10"). + Returns the resulting type in the typSpec var parameter, + also creates a complete type chain for the element type + or types for multidimensional arrays. + + Parses the end of the array spec including the right bracket + and the "OF" type declaration. +*) +procedure parseArraySpecPart(var typSpec: TypeSpec); +var rangeStart,rangeEnd: integer; + range: TypeSpec; + newType: ^TypeSpec; +begin + getRange(range); + + rangeStart := range.subStart; + rangeEnd := range.subEnd; + + typSpec.baseType := ArrayType; + typSpec.arrayStart := rangeStart; + typSpec.arrayEnd := rangeEnd; + typSpec.arrayLength := rangeEnd - rangeStart + 1; + if range.baseType = EnumType then + typSpec.indexEnumId := range.enumId + else + typSpec.indexEnumId := 0; + + new(newType); + + if checkToken(CommaToken) then + begin + readNextToken; + parseArraySpecPart(newType^); + (* need to call recursively to calculate the element sizes + from right to left *) + end + else + begin + matchToken(RBracketToken); + matchToken(OfToken); + new(newType); + parseTypeSpec(newType^, false); + end; + typSpec.elementType := newType; + typSpec.size := newType^.size * typSpec.arrayLength; +end; + +procedure addUnresolvedType(typePtr:TypeSpecPtr); +var t:TypeRef; + newItem: TypeRef; +begin + new(newItem); + newItem^.typePtr := typePtr; + newItem^.name := ''; + newItem^.next := nil; + + t := curProcedure^.unresolved; + if t = nil then + curProcedure^.unresolved := newItem + else + begin + (* get to end of list *) + while t^.next <> nil do t := t^.next; + t^.next := newItem; + end; +end; + +procedure parseAnonRecordType(var typeReturn: TypeSpec); forward; + +procedure parseTypeSpec(var typSpec: TypeSpec; allowUnresolved:boolean); +var length: integer; + pointedType: ^TypeSpec; + cnst: ConstRef; + nameStr: ^IdentString; + elementType: TypeSpec; + namebuf: IdentString; +begin + if not (curToken.tokenKind in + [ IntegerToken, RealToken, StringToken, BooleanToken, CharToken, + ArrayToken, LParenToken, IdentToken, PointerToken, NumberToken, + MinusToken, CharLitToken, SetToken, RecordToken, PackedToken ]) then + errorExit2('invalid type', curToken.tokenText); + + typSpec.size := wordSize; (* use a sensible default *) + typSpec.hasSubrange := false; + + if checkToken(LParenToken) then + begin + nextAnonTypeName(namebuf); + parseEnumDecl(namebuf, typSpec); + end + else + if checkToken(PointerToken) then + begin + readNextToken; + typSpec.baseType := PointerType; + new(pointedType); + parseTypeSpec(pointedType^, true); + typSpec.pointedType := pointedType; + (* pointers can point to a yet not declared type *) + if pointedType^.baseType = UnresolvedType then + addUnresolvedType(pointedType); + end + else + if checkToken(StringToken) then + begin + typSpec.baseType := StringType; + length := DefaultStringLength; + readNextToken; + if checkToken(LBracketToken) then + begin + readNextToken; + length := parseInteger; + matchToken(RBracketToken); + end; + typSpec.size := getStringMemSize(length); + typSpec.baseType := StringType; + typSpec.stringLength := length; + end + else if checkToken(IntegerToken) then + begin + typSpec.baseType := IntegerType; + readNextToken; + end + else if checkToken(RealToken) then + begin + typSpec.baseType := RealType; + readNextToken; + end + else if checkToken(BooleanToken) then + begin + typSpec.baseType := BooleanType; + readNextToken; + end + else if checkToken(CharToken) then + begin + typSpec.baseType := CharType; + readNextToken; + end + else if checkToken(NumberToken) or checkToken(MinusToken) then + begin + parseRangeSpec(typSpec) + end + else if checkToken(CharLitToken) then + begin + parseRangeSpec(typSpec) + end + else if checkToken(IdentToken) then + begin + (* if it is a constant it must be part of a range *) + cnst := findConstantHiera(curToken.tokenText); + if cnst <> nil then + begin + parseRangeSpec(typSpec); + end + else + begin + (* if it is not a constant, it must be a type identifier *) + typSpec := findTypeHiera(curToken.tokenText); + if typSpec.baseType = NoType then + begin + if not allowUnresolved then + errorExit2('invalid type', curToken.tokenText); + setBaseType(typSpec, UnresolvedType); + new(nameStr); + nameStr^ := curToken.tokenText; + typSpec.typeName := nameStr; + typSpec.sourceLine := lineno; + end; + readNextToken; + end; + end + else if checkToken(SetToken) then + begin + readNextToken; + matchToken(OfToken); + parseTypeSpec(elementType,false); + if not (elementType.baseType in [IntegerType, BooleanType, CharType, EnumType]) + then errorExit2('invalid set member type', lastToken.tokenText); + if elementType.baseType in [IntegerType, CharType] then + begin + if not (elementType.hasSubrange and + (elementType.subStart >=0) and (elementType.subEnd < wordBits)) then + errorExit2('Unsupported set size', ''); + end + else if elementType.baseType = EnumType then + begin + if elementType.hasSubrange then + begin + if not ((elementType.subStart >= 0) and + (elementType.subEnd < wordBits)) then + errorExit2('Unsupported set size', ''); + end + else + if elementType.enumLength > wordBits then + errorExit2('Unsupported set size', ''); + typSpec.memberEnumId := elementType.enumId; + end; + (* if it is not integer, char or enum, it is boolean, which will + most certainly within a word *) + + setBaseType(typSpec, SetType); + typSpec.memberBaseType := elementType.baseType; + typSpec.hasSubrange := elementType.hasSubrange; + typSpec.subStart := elementType.subStart; + typSpec.subEnd := elementType.subStart; + end + else + begin + optionalToken(PackedToken); + if checkToken(ArrayToken) then + begin + readNextToken; + matchToken(LBracketToken); + parseArraySpecPart(typSpec); + end + else + if checkToken(RecordToken) then + parseAnonRecordType(typSpec) + else + (* TODO: test if it really cannot happen and remove *) + (* happens at the moment with something like "packed char" *) + errorExit2('invalid type (should not happen)', curToken.tokenText); + end + +end; + +procedure parseRecordDecl(var newTypeName:IdentString); forward; + +procedure parseAnonRecordType(var typeReturn: TypeSpec); +var typeNam:IdentString; + recTypeRef: TypeRef; +begin + nextAnonTypeName(typeNam); + parseRecordDecl(typeNam); + recTypeRef := findTypeRef(curProcedure, typeNam); + typeReturn := recTypeRef^.typePtr^; +end; + +procedure validateParam(var forwardParam:SymblRef; aProc:ProcRef; + var name:IdentString; var typ:TypeSpec; isVarParam:boolean); +var valid:boolean; +begin + valid := true; + if forwardParam = nil then + valid := false + else + if forwardParam^.name <> name then + valid := false + else + if not isSameType(forwardParam^.symType, typ) then + valid := false + else + valid := forwardParam^.isVarParam = isVarParam; + + if not valid then + errorExit2('Parameters do not match forward declaration for', aProc^.name); + + forwardParam := forwardParam^.next; +end; + +procedure parseParameter(aProc: ProcRef; var forwardParam:SymblRef); +var name: IdentString; + names: StringList; + typSpec: TypeSpec; + isVarParam: boolean; +begin + initStringList(names); + + if checkToken(VarToken) then + begin + isVarParam := true; + readNextToken; + end + else + isVarParam := false; + + repeat + addToStringList(names, curToken.tokenText); + matchToken(IdentToken); + until not matchTokenOrNot(CommaToken); + matchToken(ColonToken); + parseTypeSpec(typSpec, false); + + (* create parameters with the declared type from the list of names *) + while(nextStringListItem(names, name)) do + begin + if aProc^.isForward then + validateParam(forwardParam, aProc, name, typSpec, isVarParam) + else + addParam(aProc, name, typSpec, isVarParam); + end; + + disposeStringList(names); +end; + +procedure storeArg(sym: SymblRef); +begin + if not sym^.isVarParam then + begin + (* aggregates which are not var params need to be copied *) + if sym^.symType.baseType in [ RecordType, ArrayType ] then + begin + emitLoadLocalAddr(sym^.name, sym^.offset); + emitSwap; (* COPYWORDS wants src on ToS then dest *) + emitCopy(sym^.size); + end + else if sym^.symType.baseType = StringType then + begin + emitLoadLocalAddr(sym^.name, sym^.offset); + emitSwap; (* INITSTRINGFROM wants src on ToS then dest *) + emitInitStringFrom(sym^.symType.stringLength); + end + else + emitStoreArg(sym); + end + else + emitStoreArg(sym); +end; + +procedure initLocalString(sym: SymblRef); +begin + if (not sym^.isVarParam) and (not sym^.initialized) then + begin + emitForceInitString(sym^.name, sym^.offset, sym^.symType.stringLength); + sym^.initialized := true; + end; +end; + +procedure initTemporaryString(loc: MemLocation); +begin + emitInitTempString(loc.name, loc.offset, loc.typ.stringLength); +end; + +function typeContainsString(typ: TypeSpec): boolean; +var field: FieldRef; +begin + typeContainsString := false; + + if typ.baseType = StringType then + typeContainsString := true + else + if typ.baseType = RecordType then + begin + field := typ.fields; + while (not typeContainsString) and (field <> nil) do + begin + typeContainsString := typeContainsString(field^.fieldType); + field := field^.next; + end + end + else + if typ.baseType = ArrayType then + typeContainsString := typeContainsString(typ.elementType^) +end; + +(* this procedure should initialize local variables, + but since we do not guarantee variable initialization, + we don't do anything here, for now, except for strings. + strings are normally initialized on assignment, but when + we pass them as var parameters before they have been assigned, + they need to be initialized. + If a record or an array contains a string, we call CLEARMEM + for that variable, so it can be recognized as uninitialized. *) +procedure initLocalVars(aProc: ProcRef); +var sym: SymblRef; +begin + sym := aProc^.vars.first; + while sym <> nil do + begin + if sym^.symType.baseType = StringType then + initLocalString(sym) + else if typeContainsString(sym^.symType) + and not (sym^.isVarParam or sym^.isParam) then + clearLocalVar(sym); + + sym := sym^.next; + end; +end; + +function getReturnVar(aProc: ProcRef): SymblRef; +var sym: SymblRef; +begin + sym := findSymbol(aProc^.vars, aProc^.name); + if sym = nil then + errorExit2('internal error: returnVar not found', aProc^.name) + else + getReturnVar := sym; +end; + + +(* call storeArg for each entry in the parameter list + in reverse order, using recursion *) +procedure reverseArgs(sym: SymblRef); +begin + if sym^.next <> nil then + reverseArgs(sym^.next); + storeArg(sym); +end; + +procedure fetchProcedureArgs(aProc: ProcRef); +var sym: SymblRef; +begin + if aProc^.returnsAggregate then + storeArg(getReturnVar(aProc)); + + sym := aProc^.parameters.first; + if sym <> nil then reverseArgs(sym) +end; + +procedure parseParameterList(var aProc: ProcRef); +var forwardParam:SymblRef; +begin + forwardParam := aProc^.parameters.first; + + while not checkToken(RParenToken) do + begin + if not (curToken.tokenKind in [ IdentToken, VarToken ]) then + errorExit2('Expected identifier, got', curToken.tokenText); + parseParameter(aProc, forwardParam); + if checkToken(SemicolonToken) then + begin + readNextToken; + if not (curToken.tokenKind in [ IdentToken, VarToken ]) then + errorExit2('Expected identifier, got', curToken.tokenText) + end + else + if not checkToken(RParenToken) then + errorExit2('Expected ; or ), got', curToken.tokenText); + end; +end; + +procedure parseLabelBlock; +begin + + repeat + readNextToken; + matchToken(IdentToken); + addLabel(curProcedure, lastToken.tokenText); + until not checkToken(CommaToken); + matchToken(SemicolonToken); +end; + +procedure parseProcOrFunc; +begin + if checkToken(ProcedureToken) then + parseProcedure + else if checkToken(FunctionToken) then + parseFunction + else + errorExit2('Expected PROCEDURE or FUNCTION, got', curToken.tokenText); +end; + +procedure parseProcOrFuncBody(aProc: ProcRef; returnVar: SymblRef); +begin + if checkToken(ExternalToken) then + begin + (* for an externally declared function, no + code is emitted *) + readNextToken; + end + else + if checkToken(ForwardToken) then + begin + (* for a forward declaration, just set the isForward flag *) + aProc^.isForward := true; + readNextToken; + end + else + begin + aProc^.isForward := false; (* If there was a forward declaration, + we are using its aProc record. Set the isForward field to false + for that case, to prevent multiple procedure statements. *) + + (* parse var, type, const, label statements, + also nested procedures *) + parseProgramBlock; + + emitProcedurePrologue(aProc); + fetchProcedureArgs(aProc); + initLocalVars(aProc); + parseCompoundStatement; + + if aProc^.hasExit then + emitExitLabel(aProc); + + if returnVar <> nil then + begin + (* if return value is an aggregate, + returnVar is a var parameter. in this case, + nothing needs to be done here, because + the value has already been set at the + destination. + we still return the pointer to the destination + so it can be evaluated without any special handling. *) + emitFunctionValueReturn(returnVar); + end; + emitProcedureEpilogue(aProc); + end; +end; + +procedure parseFunction; +var aProc, previousProc: ProcRef; + name: IdentString; + sym: SymblRef; + returnType: TypeSpec; + returnsAggregate: boolean; +begin + readNextToken; + + name := curToken.tokenText; + + previousProc := curProcedure; + aProc := addProcedure(name, true, previousProc); + curProcedure := aProc; + + readNextToken; + if checkToken(LParenToken) then + begin + readNextToken; + parseParameterList(aProc); + matchToken(RParenToken); + end; + + (* parse return type declaration *) + matchToken(ColonToken); + parseTypeSpec(returnType, false); + matchToken(SemicolonToken); + + (* If we parse the function the second time after + a forward declaration, we must not add + the result variable a second time.*) + if not aProc^.isForward then + begin + (* add function name as local variable for return value *) + (* if the return value is an aggregate, + make the return value a var parameter *) + returnsAggregate := isAggregate(returnType); + sym := addSymbol(aProc^.vars, name, returnType, false, returnsAggregate); + + aProc^.returnsAggregate := returnsAggregate; + aProc^.returnType := sym^.symType; + end + else + (* take the return var from forward declaration *) + sym := findSymbol(aProc^.vars, name); + + parseProcOrFuncBody(aProc, sym); + + curProcedure := previousProc; +end; + +procedure parseProcedure; +var aProc, previousProc: ProcRef; +begin + readNextToken; + + previousProc := curProcedure; + aProc := addProcedure(curToken.tokenText, false, previousProc); + curProcedure := aProc; + + readNextToken; + if checkToken(LParenToken) then + begin + readNextToken; + parseParameterList(aProc); + matchToken(RParenToken); + end; + matchToken(SemicolonToken); + + parseProcOrFuncBody(aProc, nil); + + curProcedure := previousProc; +end; + +procedure parseVarParam(var typeReturn: TypeSpec); +var mem: MemLocation; +begin + parseMemLocation(true, mem); (* put memory loc of variable on stack *) + typeReturn := mem.typ; + if (mem.typ.baseType = StringType) and (not mem.initialized) then + begin + emitInitStringShort(mem.typ.stringLength); + mem.initialized := true; + { FIXME: the following causes a bug with string + initialization if the string is passed + as a var parameter in a nested procedure. + why was this needed in the first place? } + { mem.origSym^.initialized := true; } + end; +end; + +function isFunction(aProc: ProcRef): boolean; +begin + isFunction := aProc^.returnType.baseType <> NoType; +end; + +procedure parseNew; +var memLoc: MemLocation; + typeReturn: TypeSpec; +begin + matchToken(LParenToken); + + parseLvalue(memLoc); + matchBaseType(memLoc.typ,PointerType); + + if memLoc.typ.pointedType^.baseType = StringType then + begin + if checkToken(CommaToken) then + begin + readNextToken; + parseExpression(typeReturn); + matchBaseType(typeReturn, IntegerType); + end + else + emitLoadConstantInt(memLoc.typ.pointedType^.stringLength); + emitStringAlloc; + end + else + begin + emitLoadConstantInt(memLoc.typ.pointedType^.size); + emitMemAlloc; + + if typeContainsString(memLoc.typ.pointedType^) then + emitClearAlloc(memLoc.typ.pointedType); + end; + emitCheckAlloc; + + (*We need to call CLEARMEM when the allocated type + contains strings. + INITSTRING checks if the header is non-zero to see if + the string is already initialized, and the allocated + chunk might contain random data so it would look + like an initialized string. *) + + writeVariable(memLoc); + + matchToken(RParenToken); +end; + +procedure parseDispose; +var memLoc: MemLocation; +begin + matchToken(LParenToken); + parseMemLocation(false, memLoc); + matchBaseType(memLoc.typ, PointerType); + readVariable(memLoc); + emitMemFree; + matchToken(RParenToken); +end; + +function isFileVariable(var name:IdentString):boolean; +var sym:SymblRef; +begin + sym := findHieraSymbol(name); + if sym = nil then + errorExit2('Undeclared variable', name); + isFileVariable := isSameType(sym^.symType, fileTyp); +end; + +(* Parse optional width and precision specifications + for str and write. + Count specifies the possible number of specs (1 or 2). + If a spec is not there, + a zero is put onto the stack for each missing + spec. + *) +procedure parseFieldSpecs(var argType:TypeSpec); +var specType:TypeSpec; + max, i:integer; +begin + if argType.baseType in + [StringType, IntegerType, BooleanType, PointerType, EnumType ] then + max := 1 + else + if argType.baseType = RealType then + max := 2 + else + if argType.baseType = CharType then + max := 0 + else + max := 0; + + (* Chars should also have a field width by + the standard, but that's not very useful + and it slows things down. + We could call a different routine if a field + width is specified. We could do that for all + types of course. *) + + if max > 0 then + begin + if checkToken(ColonToken) then + begin + readNextToken; + parseExpression(specType); + matchBaseType(specType, IntegerType); + if max = 2 then + begin + if checkToken(ColonToken) then + begin + readNextToken; + parseExpression(specType); + matchBaseType(specType, IntegerType); + end + else + emitLoadConstantInt(0); + end + else + if checkToken(ColonToken) then + errorExit2('Fraction length not allowed' , ''); + end + else + for i := 1 to max do + emitLoadConstantInt(0); + end; +end; + +procedure writeByType(var typ:TypeSpec); +begin + emitWriteFileArg; + parseFieldSpecs(typ); + + if typ.baseType = StringType then + emitWrite('STRING') + else + if typ.baseType = CharType then + emitWrite('CHAR') + else + if typ.baseType = RealType then + emitWrite('REAL') + else + if typ.baseType in [ IntegerType, BooleanType, PointerType, EnumType ] then + emitWrite('INT') + else (* everything else is raw binary*) + emitWriteWords(typ.size); +end; + +procedure parseWrite(newline:boolean); +var typeReturn: TypeSpec; + isFirst:boolean; + hasFileArg:boolean; + count:integer; +begin + count := 0; + if matchTokenOrNot(LParenToken) then (* can be empty and have no parentheses *) + begin + if not checkToken(RParenToken) then (* can be empty inside parentheses *) + begin + isFirst := true; + hasFileArg := false; + repeat + parseExpression(typeReturn); + if isFirst then + begin + if isSameType(typeReturn, fileTyp) then + begin + (* File var address is on stack now + from parseExpression. + *) + hasFileArg := true; + emitCheckError; + end + else + begin + (* the first arg is already on stack and it needs to be written *) + emitDefaultOutput; + end; + end; + + (* ignore the first arg if it is a file arg *) + if not (isFirst and hasFileArg) then + writeByType(typeReturn); + + isFirst := false; + count := count + 1; + until not matchTokenOrNot(CommaToken); + if newline then + emitWriteNewline; + emitWriteEnd; + end; + matchToken(RParenToken); + end; + if (count = 0) and newline then + emitDefaultNewline; +end; + +procedure readByType(var mem:MemLocation); +begin + emitReadFileArg; + + if mem.typ.baseType = CharType then + begin + (* freadchar is a special case, it returns + a char value on the estack to make it a + bit faster. The address of the destination variable + has already been put on the stack by parseMemLocation, + so we do a writeVariable to store the result. *) + emitRead('CHAR'); + writeVariable(mem); + end + else + begin + (* For all other types, the address of the variable + is passed as a var parameter. *) + if mem.typ.baseType = StringType then + begin + if not mem.initialized then + emitInitStringSwapped(mem.typ.stringLength); + emitRead('STRING'); + end + else + if mem.typ.baseType = RealType then + emitRead('REAL') + else + if mem.typ.baseType in [IntegerType, BooleanType, PointerType] then + emitRead('INT') + else + emitReadWords(mem.typ.size); + end; +end; + +procedure parseRead(newline:boolean); +var mem: MemLocation; + isFirst:boolean; + hasFileArg:boolean; + count:integer; +begin + count := 0; + if matchTokenOrNot(LParenToken) then (* can be empty and have no parentheses *) + begin + if not checkToken(RParenToken) then (* can be empty inside parentheses *) + begin + isFirst := true; + hasFileArg := false; + repeat + parseMemLocation(true, mem); (* get destination memLoc, force indirect *) + if isFirst then + begin + if isSameType(mem.typ, fileTyp) then + begin + (* File var address is on stack now + from parseLvalue. + *) + hasFileArg := true; + (* for read/write, we generate a call to checkerror, + because otherwise when reading/writing multiple + variables, we get a runtime error if the first + read/write gets an error and a second variable + is being read/written. + But we want to be able to check with + IOResult. + For other file operations (e.g. seek), + the code in stdlib does the checkerror call. + *) + emitCheckError; + end + else + begin + emitDefaultInput; + end; + end; + (* ignore the first arg if it is a file arg *) + if not (isFirst and hasFileArg) then + readByType(mem); + + isFirst := false; + count := count + 1; + until not matchTokenOrNot(CommaToken); + if newline then + emitReadNewline + else + emitReadEnd; + matchToken(RParenToken); + end; + end; + if (count = 0) and newline then + emitReadDefaultNewline; +end; +procedure parseSimpleSP(var typeReturn: TypeSpec); +begin + readNextToken; + matchToken(LParenToken); + parseExpression(typeReturn); + matchToken(RParenToken); +end; + +procedure parseSetLength; +var argType: TypeSpec; +begin + matchToken(LParenToken); + parseExpression(argType); + matchBaseType(argType, StringType); + matchToken(CommaToken); + parseExpression(argType); + matchBaseType(argType, IntegerType); + matchToken(RParenToken); + emitSetStringLength; +end; + +procedure parseSimpleSF(var typeReturn: TypeSpec); +begin + matchToken(LParenToken); + parseExpression(typeReturn); + matchToken(RParenToken); +end; + +procedure parseChr(var typeReturn: TypeSpec); +begin + parseSimpleSF(typeReturn); + matchBaseType(typeReturn, IntegerType); + setBaseType(typeReturn, CharType); +end; + +procedure parseOrd(var typeReturn: TypeSpec); +begin + parseSimpleSF(typeReturn); + if not (typeReturn.baseType in + [ CharType, EnumType, BooleanType, IntegerType ]) then + errorExit2('invalid argument type for ORD', ''); + (* no code is required, just the type conversion *) + setBaseType(typeReturn, IntegerType); +end; + +procedure parseOdd(var typeReturn: TypeSpec); +begin + parseSimpleSF(typeReturn); + matchBaseType(typeReturn, IntegerType); + setBaseType(typeReturn, BooleanType); + emitOdd; +end; + +procedure parseAbs(var typeReturn: TypeSpec); +begin + parseSimpleSF(typeReturn); + if typeReturn.baseType = IntegerType then + emitAbsInt + else + if typeReturn.baseType = RealType then + emitAbsFloat32 + else + errorExit2('Integer or real type required for ABS', ''); +end; + +procedure parseTrunc(var typeReturn: TypeSpec); +begin + parseSimpleSF(typeReturn); + matchBaseType(typeReturn, RealType); + emitTruncFloat; + setBaseType(typeReturn, IntegerType); +end; + +procedure parseFrac(var typeReturn: TypeSpec); +begin + parseSimpleSF(typeReturn); + matchBaseType(typeReturn, RealType); + emitFractFloat; +end; + +procedure parseInt(var typeReturn: TypeSpec); +begin + parseSimpleSF(typeReturn); + matchBaseType(typeReturn, RealType); + emitIntFloat; +end; + +procedure parseSucc(var typeReturn: TypeSpec); +begin + parseSimpleSF(typeReturn); + if typeReturn.baseType in [ IntegerType, CharType ] then + emitInc(1) + else + if typeReturn.baseType = EnumType then + begin + emitInc(1); + emitEnumCheck(typeReturn.enumLength - 1); + end + else + errorExit2('Integer, char or enum type expected', ''); +end; + +procedure parsePred(var typeReturn: TypeSpec); +begin + parseSimpleSF(typeReturn); + if typeReturn.baseType in [ IntegerType, CharType ] then + emitDec(1) + else + if typeReturn.baseType = EnumType then + begin + emitDec(1); + emitEnumCheck(typeReturn.enumLength - 1); + end + else + errorExit2('integer, char or enum type expected', ''); +end; + +procedure parseSqr(var typeReturn: TypeSpec); +begin + parseSimpleSF(typeReturn); + if typeReturn.baseType = IntegerType then + emitSqrInt + else + if typeReturn.baseType = RealType then + emitSqrFloat + else + errorExit2('integer or real argument expected for sqr', ''); +end; + +procedure parseValSP; +var valType:TypeSpec; + codeType:TypeSpec; + strType:TypeSpec; +begin + matchToken(LParenToken); + + parseExpression(strType); (* first arg must be a string *) + matchBaseType(strType, StringType); + + matchToken(CommaToken); + + parseVarParam(valType); (* this can be integer or real *) + + matchToken(CommaToken); + + parseVarParam(codeType); (* the return code must be integer *) + + if valType.baseType = IntegerType then + emitValCall('INT') + else + if valType.baseType = RealType then + emitValCall('REAL') + else + errorExit2('Expected INTEGER or REAL variable',''); + + matchBaseType(codeType, IntegerType); + + matchToken(RParenToken); +end; + +procedure parseStrSP; +var numType:TypeSpec; + argType:TypeSpec; +begin + matchToken(LParenToken); + parseExpression(numType); + + parseFieldSpecs(numType); + + matchToken(CommaToken); + parseExpression(argType); (* FIXME: use parseVarParam *) + matchBaseType(argType, StringType); + + if numType.baseType = IntegerType then + emitStrCall('INT') + else + if numType.baseType = RealType then + emitStrCall('REAL') + else + errorExit2('Invalid argument type close to', lastToken.tokenText); + + matchToken(RParenToken); +end; + +procedure parseExitSP; +begin + (* check for optional empty parentheses *) + if matchTokenOrNot(LParenToken) then + (* we do not support parameters for exit() *) + matchToken(RParenToken); + + if not curProcedure^.hasExit then + curProcedure^.hasExit := true; + emitExit(curProcedure); +end; + +procedure spNotImplemented; +begin + errorExit2('special procedure/function not implemented:', lastToken.tokenText); +end; + +procedure parseSpecialFunction(sf: SpecialFunc; var returnType: TypeSpec); +begin + case sf of + NoSF: + errorExit2('internal error in parseSpecialFunction:', curToken.tokenText); + TruncSF: + parseTrunc(returnType); + FracSF: + parseFrac(returnType); + IntSF: + parseInt(returnType); + SqrSF: + parseSqr(returnType); + SuccSF: + parseSucc(returnType); + PredSF: + parsePred(returnType); + OddSF: + parseOdd(returnType); + ChrSF: + parseChr(returnType); + OrdSF: + parseOrd(returnType); + AbsSF: + parseAbs(returnType); + end; +end; + +procedure parseSpecialProcCall(sp: SpecialProc); +begin + case sp of + NoSP: + errorExit2('internal error in parseSpecialProcCall', lastToken.tokenText); + NewSP: + parseNew; + DisposeSP: + parseDispose; + ReadSP: + parseRead(false); + WriteSP: + parseWrite(false); + ReadlnSP: + parseRead(true); + WritelnSP: + parseWrite(true); + SetlengthSP: + parseSetLength; + ValSP: + parseValSP; + StrSP: + parseStrSP; + ExitSP: + parseExitSP; + (* TODO: inc() and dec() *) + end; +end; + +procedure parseProcedureCall(var name: IdentString); +var aProc: ProcRef; + noMemLocation: MemLocation; + sp: SpecialProc; +begin + sp := NoSP; + readNextToken; + aProc := searchProcedure(name); + + if aProc = nil then (* no procedure found, try special procedures *) + sp := findSpecialProcedure(name); + + if (aProc = nil) and (sp = NoSP) then + (* neither regular nor special procedure, error *) + errorExit2('Undeclared identifier', name); + + if sp <> NoSP then + parseSpecialProcCall(sp) + else + begin + if isFunction(aProc) then + errorExit2('function cannot be called as a procedure:', name); + + initNoMemLocation(noMemLocation); + parseCall(aProc, noMemLocation); + end; +end; + +function markTemporaries(aProc: ProcRef): integer; +begin + markTemporaries := aProc^.tempsSize; +end; + +procedure allocTemporary(aProc: ProcRef; + var typ: TypeSpec; var memLocReturn: MemLocation); +begin + aProc^.tempsSize := aProc^.tempsSize + typ.size; + memLocReturn.memLoc := TemporaryMem; + memLocReturn.offset := aProc^.tempsSize; + memLocReturn.name := ''; + memLocReturn.typ := typ; + memLocReturn.initialized := false; +end; + +procedure releaseTemporaries(aProc: ProcRef; offset: integer); +begin + aProc^.tempsSize := offset; +end; + + +(* + If the procedure has an aggregate return value, + you can pass a MemLocation for the return variable + so it can be used in an aggregate assignment without using + a temporary. + Otherwise, you should pass a MemLocation instance where + the memLoc field is set to NoMem. A temporary is then created + and its MemLocation passed back in optionalDest. + + Argument passing: Args are passed on the eval stack. + + If a nested procedure is called, a pointer to the parent's + stack frame is passed as an invisible first arg + (needs to be stored at offset 0). + + For aggregate returns, a temporary is allocated and + passed as a invisible var parameter at the last arg + position. This is used by the called function as the return + variable. + *) + +procedure parseCall(aProc: ProcRef; var optionalDest: MemLocation); +var arg: SymblRef; + typeReturn: TypeSpec; + tempRetval: MemLocation; + retvalVar: SymblRef; + +begin + initNoMemLocation(tempRetval); + + arg := aProc^.parameters.first; + + if arg = nil + then + begin + if checkToken(LParenToken) then + begin + readNextToken; + matchToken(RParenToken); + end + end + else + begin + matchToken(LParenToken); + repeat + (* FIXME: dont convert for var params - why?*) + if arg^.isVarParam then + parseVarParam(typeReturn) + else + if arg^.symType.baseType = SetType then + (* special handling of sets for set literals *) + parseSetExpression(typeReturn) + else + parseExpression(typeReturn); + (* TODO: release temporaries after each parameter *) + matchAndConvertTypes(arg^.symType, typeReturn); + if arg^.symType.hasSubrange then + emitSubrangeCheck(arg^.symType.subStart, arg^.symType.subEnd); + arg := arg^.next; + if arg <> nil then + matchToken(CommaToken); + until arg = nil; + matchToken(RParenToken); + end; + + (* if the called function returns an aggregate, allocate a temporary + and pass it as an invisible arg. + this arg is passed last and becomes the return value local variable. *) + if aProc^.returnsAggregate then + begin + retvalVar := getReturnVar(aProc); + (* allocate space on program stack *) + allocTemporary(curProcedure, retvalVar^.symType, tempRetval); + optionalDest := tempRetVal; + (* string temporaries need to be initialized *) + if retvalVar^.symType.baseType = StringType then + initTemporaryString(tempRetval); + (* put the address of the temporary on the stack *) + emitLoadTempAddr(tempRetval.name, tempRetval.offset); + end; + + emitProcedureCall(aProc); + + { + if aProc^.returnsAggregate then + writeln('***** parseCall returnsAggregate ', aProc^.returnsAggregate); + } +end; + +(* parse the right hand side of an assignment and generate code *) +procedure parseAssignmentPart(sym: SymblRef; var mem: memLocation); +var typeReturn: TypeSpec; +begin + if mem.typ.baseType = StringType + then + (* we need to pass the memLoc here because the + result is directly written to the destination + in the optimized case *) + parseStringExpression(mem) + else if mem.typ.baseType = SetType + then + begin + (* parsing a set expression leaves a word on the stack + so we don't need a memLoc and explicitly call + writeVariable here *) + parseSetExpression(typeReturn); + writeVariable(mem); + end + else + begin + parseExpression(typeReturn); + matchAndConvertTypes(mem.typ, typeReturn); + writeVariable(mem); + end; +end; + +(* parse a complete assignment statement and generate code *) +procedure parseAssignment(sym: SymblRef); +var mem: memLocation; +begin + parseLvalue(mem); + matchToken(AssignmentToken); + parseAssignmentPart(sym, mem); +end; + +procedure initConstListItem(var value:ConstListItem); +begin + value.next := nil; + value.name := ''; + value.arrayValue := nil; + value.strValue := nil; + value.enumRef := nil; +end; + +procedure getConstValue(var value:ConstListItem); +var digits:string[24]; + typ:TypeSpec; + cnst:ConstRef; + newStr: ConstStrRef; +begin + if checkToken(NumberToken) or checkToken(MinusToken) then + begin + getNumber(digits, typ); + + if typ.baseType = IntegerType then + value.intValue := integerFromString(digits) + else if typ.baseType = RealType then + value.realValue := realFromString(digits) + else + errorExit2('internal error getConstValue', digits); + end + else if checkToken(StringLitToken) then + begin + setBaseType(typ, StringType); + newStr := addConstStr(curToken.tokenText); + value.strValue := newStr; + readNextToken; + end + else if checkToken(CharLitToken) then + begin + setBaseType(typ, CharType); + (* char constants are stored as integer *) + value.intValue := getCharValue; + end + else if checkToken(TrueToken) or checkToken(FalseToken) then + begin + setBaseType(typ, BooleanType); + (* boolean constants are stored as integer *) + value.intValue := ord(getBooleanValue); + end + else if checkToken(IdentToken) then + begin + cnst := findConstantHiera(curToken.tokenText); + if cnst = nil then + errorExit2('Constant expected, got', curToken.tokenText); + (* copy all relevant fields *) + value.typ := cnst^.typ; + value.realValue := cnst^.realValue; + value.intValue := cnst^.intValue; + value.arrayValue := cnst^.arrayValue; + value.strValue := cnst^.strValue; + value.enumRef := cnst^.enumRef; + typ := value.typ; + readNextToken; + end + else + errorExit2('Constant value expected, got', curToken.tokenText); + value.typ := typ; +end; + +procedure getStringValue(var dest:KeywordString); +var cnst:ConstRef; +begin + if checkToken(IdentToken) then + begin + cnst := findConstantHiera(curToken.tokenText); + if cnst = nil then + errorExit2('String constant expected, got', curToken.tokenText); + if cnst^.typ.baseType <> StringType then + errorExit2('String constant expected, got', curToken.tokenText); + dest := cnst^.strValue^.value; + readNextToken; + end + else + begin + if not matchTokenOrNot(CharLitToken) then + matchToken(StringLitToken); + dest := lastToken.tokenText; + end; +end; + +(* encode a constant value of a simple type in our most basic type (integer) + which is used to store constant data for variable initializations *) +function encodeConstValue(var constValue:ConstListItem): integer; +begin + if constValue.typ.baseType = RealType then + (* this makes the assumption that a real fits into an integer *) + encodeConstValue := encodefloat32(constValue.realValue) + else + encodeConstValue := constValue.intValue; +end; + +procedure parseArrayLitValue(constData: ArrayConstRef; var typ: TypeSpec); +var count, endCount: integer; +begin + matchToken(LParenToken); + endCount := typ.arrayLength; + for count := 1 to endCount do + begin + parseConstValue(constData, typ.elementType^); + if count < endCount then + matchToken(CommaToken); + end; + matchToken(RParenToken); +end; + +procedure parseRecordLitValue(constData: ArrayConstRef; var typ: TypeSpec); +var curField:FieldRef; +begin + matchToken(LParenToken); + + curField := typ.fields; + while curField <> nil do + begin + if curField^.isVariant then + errorExit2('variant records cannot be initialized',''); + + if isSimpleType(curField^.fieldType) + or (curField^.fieldType.baseType = StringType) then + begin + parseConstValue(constData, curField^.fieldType); + end + else + if curField^.fieldType.baseType = ArrayType then + parseArrayLitValue(constData, curField^.fieldType) + else + errorExit2('invalid record field initialization for', + curField^.name); + curField := curField^.next; + if curField <> nil then + matchToken(CommaToken); + end; + + matchToken(RParenToken); +end; + +procedure parseConstValue(constData: ArrayConstRef; var expectedType: TypeSpec); +var constValue:ConstListItem; + strConst: KeywordString; +begin + if expectedType.baseType = StringType then + begin + getStringValue(strConst); + addStrConstElem(constData, strConst, expectedType.stringLength); + end + else + if expectedType.baseType = ArrayType then + parseArrayLitValue(constData, expectedType) + else + if expectedType.baseType = RecordType then + parseRecordLitValue(constData, expectedType) + else + begin + initConstListItem(constValue); + getConstValue(constValue); + matchTypes(constValue.typ, expectedType); + addArrayConstElem(constData, encodeConstValue(constValue)); + end; +end; + +procedure parseVarInitialization(sym:SymblRef); +var baseType: SymbolType; + constValue:ConstListItem; + constData:ArrayConstRef; + first: boolean; +begin + first := true; + + if curProcedure <> mainProcedure then + errorExit2('Only global variables can be initialized:', sym^.name); + + baseType := sym^.symType.baseType; + + if baseType = StringType then + begin + (* strings with initialization data are handled like arrays + with opaque data *) + constData := addNamedArrayConst(sym^.name, first); + parseConstValue(constData, sym^.symType); + end + else if isSimpleType(sym^.symType) then + begin + initConstListItem(constValue); + getConstValue(constValue); + sym^.initialValue := constValue.intValue; + end + else if baseType = ArrayType then + begin + constData := addNamedArrayConst(sym^.name, first); + parseArrayLitValue(constData, sym^.symType); + end + else if baseType = RecordType then + begin + constData := addNamedArrayConst(sym^.name, first); + parseRecordLitValue(constData, sym^.symType); + end + else + errorExit2('internal error in parseVarInitialization: invalid baseType for', + sym^.name); + + sym^.hasInitialValue := true; +end; + +procedure parseSingleVarStatement; +var name: IdentString; + sym: SymblRef; + names: StringList; + typSpec: TypeSpec; + hasNext: boolean; + isExternal: boolean; +begin + (* first, gather list of variable names *) + initStringList(names); + repeat + matchToken(IdentToken); + addToStringList(names, lastToken.tokenText); + until not matchTokenOrNot(CommaToken); + matchToken(ColonToken); + + parseTypeSpec(typSpec, false); + + (* handle initialization *) + if checkToken(EqToken) then + begin + readNextToken; + + hasNext := nextStringListItem(names, name); + if not hasNext then + errorExit2('internal error when parsing var statement',''); + sym := addSymbol(curProcedure^.vars, name, typSpec, false, false); + parseVarInitialization(sym); + (* check if there is more than one variable *) + hasNext := nextStringListItem(names, name); + if hasNext then + errorExit2('Cannot initialize multiple variables:',name); + end + else + begin + (* if external keyword follows after the type spec, it is + an external variable *) + isExternal := matchTokenOrNot(ExternalToken); + (* create variables with the declared type from the list of names *) + while(nextStringListItem(names, name)) do + begin + sym := addSymbol(curProcedure^.vars, name, typSpec, false, false); + if isExternal then + if curProcedure = mainProcedure + then + sym^.isExternal := true + else + errorExit2('Local variable cannot be declared external', name); + end; + end; + + disposeStringList(names); +end; + +procedure parseVarBlock; +begin + matchToken(VarToken); + while checkToken(IdentToken) do + begin + parseSingleVarStatement; + matchToken(SemicolonToken); + end; +end; + +procedure parseForInStatement(var sym:SymblRef;forNo:integer); +var containerType:TypeSpec; + mem: MemLocation; + elementMem: MemLocation; +begin + matchToken(InToken); + (* parseMemLocation(true, container); containerType := container^.typ; *) + parseExpression(containerType); + (* TODO: would be nice if for-in worked with enum types *) + if containerType.baseType = ArrayType then + begin + matchTypes(containerType.elementType^, sym^.symType); + matchToken(DoToken); + + emitForInHeader(containerType.arrayLength); + emitForInStart(forNo); + accessVariable(sym, mem); + elementMem.memLoc := Indirect; + elementMem.typ := containerType.elementType^; + elementMem.origSym := nil; + elementMem.name := ''; + elementMem.offset := 0; + elementMem.scopeDistance := 0; + elementMem.initialized := false; + emitForInMid(sym, mem); + readVariable(elementMem); + writeVariable(mem); + + parseCompoundStatement; + + emitForInIter(forNo, containerType); + emitForInEnd(forNo); + end + else + if containerType.baseType = StringType then + begin + matchBaseType(sym^.symType, CharType); + matchToken(DoToken); + + emitForInStrHeader; + emitForInStart(forNo); + accessScalar(sym, mem); + emitForInStrMid(sym, mem); + writeVariable(mem); + + parseCompoundStatement; + + emitForInStrIter(forNo); + emitForInEnd(forNo); + end + else + errorExit2('Array or string expected', lastToken.tokenText); +end; + +procedure parseForStatement; +var sym: SymblRef; + name: IdentString; + typeReturn: TypeSpec; + mem: MemLocation; + tmpCount: integer; + down: boolean; + prevBreakLabel:IdentString; +begin + readNextToken; + tmpCount := forCount; + forCount := forCount + 1; + prevBreakLabel := curBreakLabel; + curBreakLabel := getForEndLabel(tmpCount); + name := curToken.tokenText; + sym := findHieraSymbol(name); + if sym = nil then + errorExit2('Undeclared variable', name); + readNextToken; + if checkToken(InToken) then + parseForInStatement(sym, tmpCount) + else + begin + matchToken(AssignmentToken); + if not (sym^.symType.baseType in [ IntegerType, CharType, BooleanType, + EnumType ]) then + errorExit2('Invalid type for loop variable', sym^.name); + accessScalar(sym, mem); (* FOR initializer *) + parseAssignmentPart(sym, mem); + + if not (curToken.tokenKind in [ ToToken, DowntoToken ]) then + errorExit2('Expected TO or DOWNTO, got', curToken.tokenText); + down := checkToken(DowntoToken); + readNextToken; + + parseExpression(typeReturn); (* FOR end condition is kept on stack *) + matchTypes(typeReturn, sym^.symType); + + emitForStart(tmpCount); + + (* read and check loop variable *) + accessScalar(sym, mem); + readVariable(mem); + if down then + emitForDowntoBranch(tmpCount) + else + emitForBranch(tmpCount); + (* We need to check for a subrange at the start of the loop, not + at the end. After the last iteration the control + variable will be out of range, so we cannot do the subrange + check there. *) + if (sym^.symType.baseType = IntegerType) and + (sym^.symType.hasSubrange) then + begin + (* need to read the variable again *) + accessScalar(sym, mem); + readVariable(mem); + emitSubrangeCheckRaw(sym^.symType.subStart, sym^.symType.subEnd); + end; + + matchToken(DoToken); + parseCompoundStatement; (* FOR body *) + accessScalar(sym, mem); (* increment counter variable *) + accessScalar(sym, mem); (* load mem loc twice for write and read *) + readVariable(mem); + if down then + emitDec(1) + else + emitInc(1); + writeVariable2(mem, false); + emitForEnd(tmpCount); (* branch to beginning of loop *) + end; + curBreakLabel := prevBreakLabel; +end; + +procedure parseIfStatement; +var tmpCount: integer; + typeReturn: TypeSpec; +begin + readNextToken; + tmpCount := ifCount; (* local copy of the if counter to allow for nested ifs *) + ifCount := ifCount + 1; + parseExpression(typeReturn); + matchBaseType(typeReturn, BooleanType); + matchToken(ThenToken); + emitIfBranch(tmpCount); + parseCompoundStatement; + if matchTokenOrNot(ElseToken) then + begin + emitElseBranch(tmpCount); + emitElseLabel(tmpCount); + parseCompoundStatement; + end + else + emitElseLabel(tmpCount); + emitIfLabel(tmpCount); +end; + +procedure parseWhileStatement; +var tmpCount: integer; + typeReturn: TypeSpec; + prevBreakLabel: IdentString; +begin + readNextToken; + tmpCount := whileCount; + whileCount := whileCount + 1; + prevBreakLabel := curBreakLabel; + curBreakLabel := getWhileEndLabel(tmpCount); + emitWhileStart(tmpCount); + parseExpression(typeReturn); + matchBaseType(typeReturn, BooleanType); + emitWhileBranch(tmpCount); + matchToken(DoToken); + parseCompoundStatement; + emitWhileEnd(tmpCount); + curBreakLabel := prevBreakLabel; +end; + +procedure parseRepeatStatement; +var tmpCount: integer; + typeReturn: TypeSpec; + prevBreakLabel: IdentString; +begin + readNextToken; + tmpCount := repeatCount; + repeatCount := repeatCount + 1; + prevBreakLabel := curBreakLabel; + curBreakLabel := getRepeatEndLabel(tmpCount); + emitRepeatStart(tmpCount); + repeat + parseStatement; + until matchEndOf(UntilToken); + parseExpression(typeReturn); + matchBaseType(typeReturn, BooleanType); + emitRepeatBranch(tmpCount); + emitRepeatEnd(tmpCount); + curBreakLabel := prevBreakLabel; +end; + +procedure parseCaseStatement; +var tmpCount, caseLabelCount, caseSubValCount: integer; + selectorType, caseType: TypeSpec; +begin + readNextToken; + tmpCount := caseCount; + caseCount := caseCount + 1; + caseLabelCount := 0; + + parseExpression(selectorType); (* parse case selector *) + matchToken(OfToken); + + emitCaseStart(tmpCount); + repeat + caseSubValCount := 0; + repeat + (* emit the label which is used by the previous case clause if + it does not match *) + emitCaseLabelStart(tmpCount, caseLabelCount, caseSubValCount); + parseConstant(caseType); + if matchTokenOrNot(DotToken) then + begin + if matchTokenOrNot(DotToken) then + begin + (* handle ranges which use two comparisons *) + emitCaseRangeLoBranch(tmpCount, caseLabelCount, caseSubValCount, true); + parseConstant(caseType); + emitCaseRangeHiBranch(tmpCount, caseLabelCount, caseSubValCount, + not checkToken(CommaToken)); + end + end + else + emitCaseLabelBranch(tmpCount, caseLabelCount, caseSubValCount, + not checkToken(CommaToken)); + matchTypes(selectorType, caseType); + caseSubValCount := caseSubValCount + 1; + until not matchTokenOrNot(CommaToken); + matchToken(ColonToken); + (* this label is used for clauses with multiple values to jump to on a match *) + emitCaseLabelMatch(tmpCount, caseLabelCount); + (* parse the (compound) statement which is executed on a match *) + parseCompoundStatement; + emitCaseLabelEnd(tmpCount); + (* last normal clause may omit the semicolon, otherwise it is required *) + if not (curToken.tokenKind in [ EndToken, ElseToken]) then + matchToken(SemicolonToken); + (* emit label to catch the last conditional branch of a multi-value clause *) + emitCaseLabelLabel(tmpCount, caseLabelCount, caseSubValCount); + caseLabelCount := caseLabelCount + 1; + + (* check for a final ELSE clause *) + if checkToken(ElseToken) then + begin + readNextToken; + (* just generate the code, which will be put after + the last no-match-label and therefore will be + executed if the last clause does not match *) + parseCompoundStatement; + if checkToken(SemicolonToken) then readNextToken; + if not checkToken(EndToken) then + errorExit2('ELSE must be last case clause', curToken.tokenText); + end; + until matchTokenOrNot(EndToken); + emitCaseEnd(tmpCount, caseLabelCount); +end; + +procedure parseBreakStatement; +begin + if length(curBreakLabel) = 0 then + errorExit2('BREAK not within loop', ''); + emitBreak(curBreakLabel); + readNextToken; +end; + +procedure disposeWithStmntTmp; +begin + with withStmntStack[withStmntCount] do + begin + if tmpSymbol <> nil then + begin + dispose(tmpSymbol); + tmpSymbol := nil; + end; + end; +end; + +procedure parseWithStmntPart; +var withLoc, tLoc: MemLocation; + tempType: TypeSpec; +begin + parseMemLocation(true,withLoc); (* parse the memory location of the record to be opened *) + (* allocate a temporary for the address of the record *) + setBaseType(tempType, PointerType); + allocTemporary(curProcedure, tempType, tLoc); + + (* add it to the with-stack *) + withStmntCount := withStmntCount + 1; + if withStmntCount > WithStackDepth then + errorExit2('Too many nested WITH statements',''); + withStmntStack[withStmntCount].tmpSymbol := nil; + + with withStmntStack[withStmntCount] do + begin + recordLoc := withLoc; (* the memloc of the opened record *) + tempLoc := tLoc; (* the memloc of the temporary which stores the + address of the opened record *) + end; + + (* store the record address to the temporary *) + emitLoadTempAddr(withLoc.name, tLoc.offset); + emitSwap; + emitStoreIndirect; +end; + +procedure parseWithStatement; +var tempMark: integer; + oldWithStmntCount: integer; +begin + tempMark := markTemporaries(curProcedure); + oldWithStmntCount := withStmntCount; + + readNextToken; + + (* the with clause can contain multiple comma separated records *) + repeat + parseWithStmntPart; + until not matchTokenOrNot(CommaToken); + + matchToken(DoToken); + + parseCompoundStatement; + + (* remove entries from with-stack *) + while withStmntCount > oldWithStmntCount do + begin + disposeWithStmntTmp; + withStmntCount := withStmntCount -1; + end; + + releaseTemporaries(curProcedure,tempMark); +end; + +procedure parseLabel(var aLabl:LablRef); +begin + emitLabel(aLabl); + readNextToken; + matchToken(ColonToken); +end; + +procedure parseStatement; +var sym: SymblRef; + cnst: ConstRef; + aLabl: LablRef; + name: IdentString; + tempMark: integer; +begin + (* temporaries used during the statement + can be released afterwards, so mark + the temp space now and release later *) + tempMark := markTemporaries(curProcedure); + + (* try to parse a label before every statement. + if we succeed, continue to parse (because there is no + semicolon after a label, so it is not a complete statement) + *) + if checkToken(IdentToken) then + begin + name := curToken.tokenText; + aLabl := findLabel(curProcedure, name); + if aLabl <> nil then + parseLabel(aLabl); + end; + + if checkToken(GotoToken) then + begin + readNextToken; + matchToken(IdentToken); + aLabl := findLabel(curProcedure, lastToken.tokenText); + if aLabl = nil then errorExit2('GOTO to undefined label', lastToken.tokenText); + emitLabelJump(aLabl); + end + else + if checkToken(IfToken) then + parseIfStatement + else + if checkToken(WhileToken) then + parseWhileStatement + else + if checkToken(RepeatToken) then + parseRepeatStatement + else + if checkToken(ForToken) then + parseForStatement + else + if checkToken(BreakToken) then + parseBreakStatement + else + if checkToken(CaseToken) then + parseCaseStatement + else + if checkToken(WithToken) then + parseWithStatement + else + if checkToken(IdentToken) then + begin + (* this can be either a procedure call or an assignment *) + name := curToken.tokenText; + sym := findHieraSymbol(name); + if sym <> nil + then + parseAssignment(sym) + else + begin + (* check if it is a constant *) + cnst := findConstantHiera(name); + if cnst <> nil then + errorExit2('variable identifier expected, got constant', name); + + (* now it can only be a procedure *) + parseProcedureCall(name); + end; + end + else + begin + if (curToken.tokenKind = ElseToken) then + begin + (* two consecutive else tokens mean an empty else clause followed by another*) + if not (lastToken.tokenKind in [ElseToken, ThenToken]) then + errorExit2('Unexpected ELSE, check for erroneous ; after previous statement', + '') + end + else if not (curToken.tokenKind in [SemicolonToken, EndToken, UntilToken ]) then + begin + (* For an empty statement, the semicolon or end token is not consumed. + If not an empty statement, it is an error. *) + errorExit2('Unexpected token', quoteToken(keywords[curToken.tokenKind])); + end; + end; + + releaseTemporaries(curProcedure, tempMark); +end; + +procedure parseRecordField(var recordTyp: TypeSpec; var offset:integer; + isVariant:boolean; tagField:FieldRef; var tagValues:IntList); +var fieldType: TypeSpec; + fieldName: IdentString; + curField: ^FieldListItem; + newField: ^FieldListItem; + names: StringList; +begin + initStringList(names); + repeat + addToStringList(names, curToken.tokenText); + matchToken(IdentToken); + until not matchTokenOrNot(CommaToken); + matchToken(ColonToken); + + parseTypeSpec(fieldType, false); + + curField := recordTyp.fields; + (* go to last field in list *) + if curField <> nil then + while curField^.next <> nil do curField := curField^.next; + + while(nextStringListItem(names, fieldName)) do + begin + + new(newField); + newField^.name := fieldName; + newField^.offset := offset; + newField^.fieldType := fieldType; + newField^.isVariant := isVariant; + newField^.tagField := tagField; + newField^.tagValues := tagValues; + newField^.next := nil; + + if curField = nil then + recordTyp.fields := newField + else + curField^.next := newField; + + curField := newField; + + offset := offset + fieldType.size; + end; + + disposeStringList(names); +end; + +procedure parseRecordFields(var recordTyp: TypeSpec; var offset:integer; + isVariant:boolean; tagField:FieldRef; var tagValues:IntList); +begin + while checkToken(IdentToken) do + begin + parseRecordField(recordTyp, offset, isVariant, tagField, tagValues); + if checkToken(SemicolonToken) then + readNextToken; + end; +end; + +procedure parseVariantRecord(var recordTyp: TypeSpec; var offset:integer); +var tagField:FieldRef; + tagValue:integer; + tagValueType:TypeSpec; + variantOffset:integer; + maxSize:integer; + caseValues: IntList; +begin + matchToken(CaseToken); + + parseRecordField(recordTyp, offset, false, nil, emptyIntList); + (* get the tag field which was just added at then end of the list *) + tagField := recordTyp.fields; + while tagField^.next <> nil do tagField := tagField^.next; + + matchToken(OfToken); + + maxSize := 0; + repeat + variantOffset := offset; + initIntList(caseValues); + (* there can be a comma-separated list of case values *) + repeat + getRangePart(tagValue, tagValueType); + addToIntList(caseValues, tagValue); + until not matchTokenOrNot(CommaToken); + matchToken(ColonToken); + matchToken(LParenToken); + parseRecordFields(recordTyp, variantOffset, true, tagField, caseValues); + if variantOffset > maxSize then + maxSize := variantOffset; + matchToken(RParenToken); + matchToken(SemicolonToken); + { + while nextIntListItem(caseValues, tagValue) do + writeln('******* parseVariantRecord case values:', tagValue); + } + rewindIntList(caseValues); + + (* the caseValues list is not disposed, it stays attached to + the field list of the record type *) + until checkToken(EndToken); + offset := maxSize; +end; + +procedure parseRecordDecl(var newTypeName:IdentString); +var offset: integer; + recordTyp: TypeSpec; +begin + offset := 0; + + setBaseType(recordTyp, RecordType); + recordTyp.fields := nil; + + matchToken(RecordToken); + repeat + if checkToken(CaseToken) then + parseVariantRecord(recordTyp, offset) + else + parseRecordField(recordTyp, offset, false, nil, emptyIntList); + + if checkToken(SemicolonToken) then + readNextToken + else if not checkToken(EndToken) then + errorExit2('Expected ; or END, got', curToken.tokenText); + until checkToken(EndToken); + readNextToken; + + recordTyp.size := offset; + + addType(recordTyp, newTypeName); +end; + +procedure parseEnumDecl(var name:IdentString;var typeReturn: TypeSpec); +var ident: IdentString; + value: integer; + cnst: ConstRef; + enumTyp: TypeSpec; + enumRef: TypeRef; + identList: StringList; +begin + value := 0; + initStringList(identList); + + setBaseType(enumTyp, EnumType); + addType(enumTyp, name); + enumRef := findTypeRef(curProcedure, name); + + matchToken(LParenToken); + repeat + ident := curToken.tokenText; + matchToken(IdentToken); + addToStringList(identList, ident); + value := value + 1; + until not matchTokenOrNot(CommaToken); + matchToken(RParenToken); + + enumCount := enumCount + 1; + + value := 0; + while nextStringListItem(identList, ident) do + begin + cnst := addConstant(ident); + cnst^.typ.baseType := EnumType; + cnst^.typ.enumId := enumCount; + cnst^.intValue := value; + cnst^.enumRef := enumRef; + value := value + 1; + end; + + enumRef^.typePtr^.enumLength := value; + enumRef^.typePtr^.enumList := identList; + enumRef^.typePtr^.enumId := enumCount; + + typeReturn := enumRef^.typePtr^; +end; + +procedure parseTypeStatement; +var newTypeName: IdentString; + newType: TypeSpec; +begin + (* newType.baseType := NoType; *) + newTypeName := curToken.tokenText; + matchToken(IdentToken); + matchToken(EqToken); + optionalToken(PackedToken); + if checkToken(RecordToken) then (* TODO: move to parseTypeSpec*) + parseRecordDecl(newTypeName) + else + if checkToken(LParenToken) then (* TODO: move to parseTypeSpec*) + parseEnumDecl(newTypeName, newType) + else + begin + parseTypeSpec(newType, false); + addType(newType, newTypeName); + end; +end; + +procedure parseTypeBlock; +begin + matchToken(TypeToken); + while checkToken(IdentToken) do + begin + parseTypeStatement; + matchToken(SemicolonToken); + end; +end; + +procedure parseConstBlock; +var name:IdentString; + typeReturn:TypeSpec; + newConst: ConstRef; +begin + matchToken(ConstToken); + repeat + matchToken(IdentToken); + name := lastToken.tokenText; + matchToken(EqToken); + + newConst := addConstant(name); + + if checkToken(LBracketToken) then + begin + setBaseType(typeReturn, NoType); + newConst^.arrayValue := getArrayConst(typeReturn); + newConst^.typ := typeReturn; + end + else + getConstValue(newConst^); + + matchToken(SemicolonToken); + until not checkToken(IdentToken); +end; + +procedure processUnresolvedTypes(aProc:ProcRef); +var typeListItem, t:TypeRef; + typePtr: ^TypeSpec; +begin + typeListItem := aProc^.unresolved; + while typeListItem <> nil do + begin + typePtr := typeListItem^.typePtr; + if typePtr^.baseType = UnresolvedType then + begin + t := findTypeRef(aProc, typePtr^.typeName^); + if t = nil then + begin + errorExit2('unresolved type', typePtr^.typeName^); + end + else + begin + (* overwrite the unresolved type spec with the one we just found *) + typeListItem^.typePtr^ := t^.typePtr^; + end; + end; + typeListItem := typeListItem^.next; + end; +end; + +procedure parseProgramBlock; +begin + (* parse var, type and const statements *) + while curToken.tokenKind in [ VarToken, TypeToken, ConstToken, LabelToken ] do + begin + if checkToken(VarToken) then parseVarBlock + else if checkToken(TypeToken) then parseTypeBlock + else if checkToken(ConstToken) then parseConstBlock + else if checkToken(LabelToken) then parseLabelBlock + end; + + processUnresolvedTypes(curProcedure); + + (* parse functions and procedures *) + while checkToken(ProcedureToken) or checkToken(FunctionToken) do + begin + parseProcOrFunc; + matchToken(SemicolonToken); + end; +end; + +procedure parseLib(n:IdentString); +var libFile: InputFileType; + prevFile: InputFileType; + prevLineno: integer; + prevFilename: string[255]; + newFilename: string[255]; +begin + prevFile := infile; + prevLineno := lineno; + prevFilename := filename; + + newFilename := n + UnitSuffix1; + openFileWithDefault(libFile, newFilename); + + filename := newFilename; + infile := libFile; + lineno := 1; + buffered := false; + + readNextToken; + + parseProgramBlock; + + if not checkToken(EOFToken) then + errorExit2('Expected ',''); + + close(libFile); + + printLineStats; + + infile := prevFile; + lineno := prevLineno; + filename := prevFilename; + + buffered := false; +end; + +procedure parseStdLib; +var name:IdentString; +begin + parseLib(StdlibName); + + (* the file type is declared in stdlib, so + we can look it up now *) + name := 'FILE'; + fileTyp := findType(mainProcedure, name); +end; + +procedure setGlobalSuffix; +begin + globalSuffix := '_' + mainProcedure^.name; +end; + +procedure parseUnit; +begin + matchToken(UnitToken); + matchToken(IdentToken); + mainProcedure^.name := lastToken.tokenText; + setGlobalSuffix; + + matchToken(SemicolonToken); + + matchToken(ImplementationToken); + + parseProgramBlock; + + matchToken(EndToken); + matchToken(DotToken); + matchToken(EOFToken); +end; + +function lower(c:char):char; +begin + if (ord(c) >= ord('A')) and + (ord(c) <= ord('Z')) then + lower := chr(ord(c) + 32) (* assumes ASCII*) + else + lower := c; +end; + +procedure parseUsesStatement; +var unitName:IdentString; + c:char; +begin + repeat + matchToken(IdentToken); + unitName := ''; + for c in lastToken.tokenText do + unitName := unitName + lower(c); + addToStringList(usedUnits, unitName); + until not matchTokenOrNot(CommaToken); + + if not checkToken(SemicolonToken) then + matchToken(SemicolonToken); + + while nextStringListItem(usedUnits, unitName) do + parseLib(unitName); + + readNextToken; (* read token from main input file *) +end; + +procedure parseProgram; +begin + (* require Program statement *) + matchToken(ProgramToken); + matchToken(IdentToken); + mainProcedure^.name := lastToken.tokenText; + (* we don't do anything with the program name *) + (* and we parse but otherwise ignore file declarations *) + if matchTokenOrNot(LParenToken) then + begin + repeat + matchToken(IdentToken); + until not matchTokenOrNot(CommaToken); + matchToken(RParenToken); + end; + matchToken(SemicolonToken); + + if matchTokenOrNot(UsesToken) then + parseUsesStatement; + + (* parse var, type and const statements and procedures/functions *) + parseProgramBlock; + + (* parse main program *) + emitMainStart(); + parseCompoundStatement; + matchToken(DotToken); + + (* nothing should be after the main program *) + matchToken(EOFToken); +end; + +procedure parseProgramOrUnit(useStdlib:boolean); +begin + if useStdlib then + parseStdlib; + + readNextToken; + + if checkToken(ProgramToken) then + begin + emitPrologue; + parseProgram; + emitEpilogue; + end + else + if checkToken(UnitToken) then + begin + parseUnit; + emitUnitEpilogue; + end + else + errorExit2('PROGRAM or UNIT expected, got', curToken.tokenText); + +end; + +function changeFileSuffix(filename: string): string; +var suffixPos:integer; +begin + suffixPos := pos(filenameSuffix, filename); + if suffixPos > 0 then + setlength(filename, suffixPos-1); + filename := filename + outfileSuffix; + changeFileSuffix := filename; +end; + +procedure initMainProcedure; +begin + mainProcedure := addProcedure('_MAIN', false, nil); + mainProcedure^.vars.scope := GlobalSymbol; + mainProcedure^.procedures := nil; + mainProcedure^.next := nil; + mainProcedure^.types := nil; + mainProcedure^.unresolved := nil; + mainProcedure^.constants := nil; + mainProcedure^.level := -1; + curProcedure := mainProcedure; +end; + +begin + initPlatform; + + buffered := false; + firstConstStr := nil; + firstArrayConst := nil; + constStrNo := 0; + arrayConstNo := 0; + ifCount := 0; + whileCount := 0; + forCount := 0; + repeatCount := 0; + caseCount := 0; + nestedProcsCount := 0; + enumCount := 0; + anonTypeCount := 0; + curBreakLabel := ''; + lineno := 1; + includeLevel := 0; + defaultHeapSize := 262144; + defaultStackSize := 16384; + withStmntCount := 0; + insCount := 0; + initStringList(usedUnits); + initIntList(emptyIntList); + initMainProcedure; + globalSuffix := ''; + useStdlib := true; + useStandalone := false; + editOnError := false; + runProg := false; + runAsm := true; + paramPos := 1; + + filename := ''; + outfilename := ''; + + while paramPos <= paramCount do + begin + if paramStr(paramPos) = '-n' then (* do not include stdlib.inc *) + useStdlib := false + else + if paramStr(paramPos) = '-s' then (* use standalone corelib *) + useStandalone := true + else + if paramStr(paramPos) = '-e' then (* call editor on error *) + editOnError := true + else + if paramStr(paramPos) = '-R' then (* run compiled/assembled program *) + runProg := true + else + if paramStr(paramPos) = '-S' then (* do not run assembler *) + runAsm := false + else + if paramStr(paramPos) = '-H' then (* set heap size *) + begin + paramPos := paramPos + 1; + DefaultHeapSize := integerFromString(ParamStr(paramPos)) * 1024; + end + else + begin + if length(filename) = 0 then + filename := paramStr(paramPos) + else + outfilename := paramStr(paramPos); + end; + paramPos := paramPos + 1; + end; + + if length(outfilename) = 0 then + outfilename := changeFileSuffix(filename); + + if length(filename) = 0 then + begin + writeln('No file name given.'); + halt; + end; + + writeln('Compiling ', filename, ' to ', outfilename); + openFileWithDefault(infile, filename); + + overwriteFile(outfile, outfilename); + + parseProgramOrUnit(useStdlib); + + printLineStats; + + cleanup; + + if runAsm then + ExecAssembler(outfilename, runProg, editOnError); +end. diff --git a/pcomp/pcomp.py b/pcomp/pcomp.py new file mode 100644 index 0000000..9bc40bc --- /dev/null +++ b/pcomp/pcomp.py @@ -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: {} ".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() diff --git a/pcomp/platfile+.pas b/pcomp/platfile+.pas new file mode 100644 index 0000000..7f4c329 --- /dev/null +++ b/pcomp/platfile+.pas @@ -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; diff --git a/pcomp/platfile+tdr.pas b/pcomp/platfile+tdr.pas new file mode 100644 index 0000000..c70e4a3 --- /dev/null +++ b/pcomp/platfile+tdr.pas @@ -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; diff --git a/pcomp/platfile-types+.pas b/pcomp/platfile-types+.pas new file mode 100644 index 0000000..5d24635 --- /dev/null +++ b/pcomp/platfile-types+.pas @@ -0,0 +1,2 @@ +(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *) +type TextFile = text; diff --git a/pcomp/platfile-types+tdr.pas b/pcomp/platfile-types+tdr.pas new file mode 100644 index 0000000..748eb15 --- /dev/null +++ b/pcomp/platfile-types+tdr.pas @@ -0,0 +1,2 @@ +(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *) +type TextFile = file; diff --git a/pcomp/platform+.pas b/pcomp/platform+.pas new file mode 100644 index 0000000..73c04c5 --- /dev/null +++ b/pcomp/platform+.pas @@ -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; diff --git a/pcomp/platform+tdr.pas b/pcomp/platform+tdr.pas new file mode 100644 index 0000000..4283bf7 --- /dev/null +++ b/pcomp/platform+tdr.pas @@ -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; diff --git a/pcomp/platform-types+.pas b/pcomp/platform-types+.pas new file mode 100644 index 0000000..797d714 --- /dev/null +++ b/pcomp/platform-types+.pas @@ -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); diff --git a/pcomp/platform-types+tdr.pas b/pcomp/platform-types+tdr.pas new file mode 100644 index 0000000..c2488f7 --- /dev/null +++ b/pcomp/platform-types+tdr.pas @@ -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); diff --git a/pcomp/sasm.pas b/pcomp/sasm.pas new file mode 100644 index 0000000..4d15987 --- /dev/null +++ b/pcomp/sasm.pas @@ -0,0 +1,2650 @@ +(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *) +{$MODE objfpc} +{$H600} +{$S4} +program sasm; +{$!}{$ifdef FPC}uses math,crt;{$endif} +{$R+} +type TokenType = ( + PlusToken, MinusToken, AsteriskToken, SlashToken, + SemicolonToken, EOFToken, EOLToken, + NumberToken, KeywordToken, LabelToken, DirectiveToken, + StringLitToken, CharLitToken, MetaKeywordToken, + CommaToken, DotToken, ColonToken, PercentToken, TildeToken, + AndToken, OrToken, XorToken, + AtToken, UnknownToken + ); + + IdentString = string[120]; + KeywordString = string[255]; + InsString = string[24]; + AddrString = string[8]; + + Token = record + tokenText: string[255]; + tokenKind: TokenType; + end; + + OperandType = ( + NoOprnd, + U13WOprnd, (* unsigned 13 bit word-aligned operand e.g. LOAD and STORE *) + S13Oprnd, (* signed 13 bit operand e.g. LOADC *) + RelWOprnd, (* signed 13 bit word-aligned operand, PC-relative, e.g. BRANCH/CBRANCH *) + S10Oprnd, (* signed 10 bit operand, e.g. FPADJ *) + U4Oprnd, (* unsigned 4 bit operand, would used for modifiers but is actually unused *) + CmpOprnd, (* comparison operand, unsigned 4 bit, actually unused *) + RegOprnd, (* register id operand for LOADREG, 4 bit unsigned *) + RelU10Oprnd, (* PC-relative 10 bit unsigned, for LOADREL *) + OptOprnd (* optional 4 bit operand for ALU *) + ); + + EncodingEntry = record + mask: integer; + value: integer; + end; + + InstructionWord = integer; + MachineWord = integer; + OutputWord = record + intvalue:integer; + end; + + ModifierEntry = record + keyword: string[24]; + encoding: EncodingEntry; + next: ^ModifierEntry; + end; + + OpcodeData = record (* the key is stored in the tree as metadata *) + encoding: EncodingEntry; + modifiers: ^ModifierEntry; + operand: OperandType; + id: integer; (* unique id for this opcode or alias *) + end; + + SymbolType = (ConstSymbol, LabelSymbol, SpecialSymbol, SkippedSymbol); + + Symbol = record + value:integer; + typ:SymbolType; + aligned:boolean; + padded:boolean; + exported:boolean; + end; + + SymbolRef = ^Symbol; + + CPoolEntry = record + labelname: string[40]; + value: KeywordString; + offset: integer; + symbolic: boolean; + sym: SymbolRef; + next: ^CPoolEntry; + prev: ^CPoolEntry; + end; + + CPoolRef = ^CPoolEntry; + + LabelList = record + name: IdentString; + next: ^LabelList; + prev: ^LabelList; + end; + + LabelListRef = ^LabelList; + + UnresolvedBranch = record + target:IdentString; + origin:integer; + maxDistance:integer; + shrinkage:integer; + labels:LabelListRef; + next:^UnresolvedBranch; + end; + + UnresBranchRef = ^UnresolvedBranch; + +{$I 'platform-types+.pas'} (* defines OutputFileType, InputFileType, SymFileType *) + + InputFileState = record + name: string; + filevar: InputFileType; + line: integer; + end; + + TreeDataType = (TDString, TDInteger, TDSymbol, TDOpcode); + Treedata = record + case typ:Treedatatype of + TDString:(stringdata:string); + TDInteger:(intdata:integer); + TDSymbol:(symboldata:Symbol); + TDOpcode:(opcodedata:OpcodeData); + end; + +{$I 'treetypes.pas'} + +const insSize = 2; + wordSize = 4; + wordSizeMask = 3; + MaxUShortOffset = 8191; + MaxShortOffset = 4095; + MaxShorterOffset = 511; + MaxTinyOffset = 15; + Unresolved = 2147483647; (* max integer - 1 *) + MaxIntegerDigits = 24; + wordBits = 32; + MaxIncludes = 4; + FilenameSuffix = '.s'; + OutfileSuffix = '.prog'; + SymFileSuffix = '.sym'; + AsciifileSuffix = '.mem'; + + progressSteps = 511; + + shortcutChar = '`'; + firstShCChar = 'A'; + lastShCChar = 'i'; + +var + curToken, nextToken, lastToken: Token; + + infileOpened: boolean; + outputEnabled: boolean; + asciiOutput: boolean; + lastOpcode: TreeDataRef; + + bufferedChar: char; + buffered: boolean; + infile: InputFileType; + outfile: OutputFileType; + filename: string; + outfilename: string; + editOnError, runOnSuccess: boolean; + lineno: integer; + prevFiles: array[1..MaxIncludes] of InputFileState; + includeLevel: integer; + paramPos: integer; + + pc: integer; + pass:integer; + + bytesCount:integer; + + symbolTable: TreeRef; + opcodeTable: TreeRef; + nextOpcodeId: integer; + constantPool: CPoolRef; + cPoolCount: integer; + nextConstId: integer; + + firstUnresBranch: ^UnresolvedBranch; + + LOADCPId: integer; + + outputPrefix: string; + includePrefix: string; + + shortcuts: array[firstShCChar..lastShCChar] of OpcodeData; + +procedure errorExit2(message1, message2: string); forward; + +{$I 'platform+.pas'} +{$I 'treeimpl.pas'} + + +procedure verifyTree(node:TreeRef); forward; + +procedure dumpSymbolTable; forward; + + +procedure cleanup; +begin + if infileOpened then + close(infile); + if outputEnabled then + close(outfile); +end; + + +procedure errorExit; +begin + cleanup; + (* dumpSymbolTable; *) + halt; +end; + +procedure errorLine(line:integer); +begin + if curToken.tokenKind = EOLToken then + lineno := lineno - 1; + writeln('at line ',lineno, ' in ', filename); +end; + +procedure errorExit2(message1, message2: string); +var errormsg:string[128]; +begin + errormsg := message1 + ' ' + message2; + writeln; + writeln('Error: ', errormsg); + errorLine(lineno); + cleanup; + if editOnError then + ExecEditor(filename, lineno, errormsg) + else + halt; +end; + +function descToken(kind:tokenType):string; +begin + case kind of + PlusToken, MinusToken, AsteriskToken, SlashToken, AndToken, OrToken, XorToken: + descToken := 'one of + - * / & | ^'; + SemicolonToken: + descToken := '";"'; + EOFToken: + descToken := 'end-of-file'; + EOLToken: + descToken := 'end-of-line'; + NumberToken: + descToken := 'number'; + KeywordToken: + descToken := 'keyword'; + LabelToken: + descToken := 'label'; + DirectiveToken: + descToken := 'directive'; + StringLitToken: + descToken := 'string literal'; + CharLitToken: + descToken := 'char literal'; + MetaKeywordToken: + descToken := 'meta directive'; + CommaToken: + descToken := '","'; + DotToken: + descToken := '"."'; + ColonToken: + descToken := '":"'; + PercentToken: + descToken := '"."'; + AtToken: + descToken := '"@"' + else + descToken := ''; + end; +end; + +procedure makeCPoolLabel(var labelname:IdentString); +var digits:string[16]; +begin + str(nextConstId, digits); + labelname := '_CP_' + digits; +end; + +procedure hexstr(value:integer;var output:string); forward; + +procedure putCPoolEntry(var constant:KeywordString; offset:integer; symbolic:boolean;var labelname:IdentString); +var newEntry:CPoolRef; +begin + makeCPoolLabel(labelname); + + new(newEntry); + + newEntry^.labelname := labelname; + newEntry^.value := constant; + newEntry^.offset := offset; + newEntry^.symbolic := symbolic; + newEntry^.next := constantPool; + newEntry^.prev := nil; + + if constantPool <> nil then + constantPool^.prev := newEntry; + constantPool := newEntry; + + nextConstId := nextConstId + 1; +end; + +function isNumber(var s:string):boolean; +begin + if isdigit(s[1]) then + isNumber := true + else + isNumber := s[1] in [ '-', '$', '%' ]; +end; + +function convertNumber(digits:KeywordString):integer; forward; +function findSymbol(var keyword:KeywordString):TreeDataRef; forward; + +procedure addCPoolEntry(var constant:KeywordString; offset:integer; var labelname:IdentString); +begin + putCPoolEntry(constant, offset, not isNumber(constant), labelname); + cPoolCount := cPoolCount + 1; +end; + +function getSymbolValue(var keyword:KeywordString):integer; forward; + +(* + Get the address of a cpool entry for a constant value. + If the pool does not contain the constant, create + a new entry. + The constant needs to be a string because it might + be a symbol. In pass 1, the value of the symbol is not + known, so to reuse a value we need to use the symbolic name. + + The offset is an optional numerical value or symbol that gets + added to the constant before it is put into the pool. + This is used by the compiler for global variables + (arrays, record fields). Can be zero. + *) + +function getCPoolAddr(var constant:KeywordString;offset:integer):integer; +var labelname:IdentString; + current:CPoolRef; + found:CPoolRef; +begin + getCPoolAddr := pc; + + found := nil; + current := constantPool; + while (current <> nil) and (found = nil) do + begin + if (constant = current^.value) and (offset = current^.offset) then + found := current; + current := current^.next; + end; + + if found <> nil then + begin + (* value already exists in pool *) + labelname := found^.labelname; + end + else + (* value not found, add it to the pool and + set the label name for the new entry *) + addCPoolEntry(constant,offset,labelname); + + (* writeln(' [P', pass, ' cpool ', constant, ' -> ', labelname, '] '); *) + getCPoolAddr := getSymbolValue(labelname); +end; + +procedure printPassNo; +begin + write('P', pass, ' '); +end; + +procedure printCurrentLineno; +begin + write(#13); + printPassNo; + write(filename, ' ', lineno); + ClrEol; +end; + +procedure printLastLineno; +begin + printCurrentLineno; +end; + +procedure beginInclude(var newname: string); +var newfile: InputFileType; +begin + if includeLevel = MaxIncludes then + errorExit2('Too many nested includes', ''); + + includeLevel := includeLevel + 1; + + prevFiles[includeLevel].filevar := infile; + prevFiles[includeLevel].name := filename; + prevFiles[includeLevel].line := lineno; + + openFileWithDefault(newfile, newname); + + infile := newfile; + filename := newname; + lineno := 1; + buffered := false; +end; + +procedure endInclude; +begin + if includeLevel = 0 then + errorExit2('Internal error in', 'endInclude'); + + close(infile); + + infile := prevFiles[includeLevel].filevar; + filename := prevFiles[includeLevel].name; + lineno := prevFiles[includeLevel].line; + + buffered := false; + + includeLevel := includeLevel - 1; +end; + +function includeIsActive:boolean; +begin + includeIsActive := includeLevel > 0; +end; + +function nextChar: char; +var ch: char; +begin + if buffered then + begin + ch := bufferedChar; + buffered := false; + end + else + begin + if not eof(infile) then + begin + read(infile, ch); + end + else + begin + (* we reached end-of-file, was this + the end of an include file? *) + if includeIsActive then + begin + (* if yes, switch back to previous file *) + endInclude; + ch := ' '; (* return a space which will get skipped *) + end + else + (* no, return null character which becomes an EOFToken *) + ch := #0; + end + end; + if ch = #10 then lineno := lineno + 1; + nextChar := ch; +end; + +function peekChar: char; +var tmpChar: char; +begin + if buffered then + begin + peekChar := bufferedChar; + end + else + begin + if not eof(infile) then + begin + read(infile, tmpChar); + peekChar := tmpChar; + bufferedChar := tmpChar; + buffered := true; + end + else + begin + (* at the eof of an include, + just return an extra space and let nextChar + do the work *) + if includeIsActive then + begin + peekChar := ' '; + buffered := false; (* force nextChar to do real I/O *) + end + else + peekChar := #0; + end + end +end; + +procedure skipWhitespace; +var c:char; +begin + while peekChar() in [ #13, #32, #9 ] do + c := nextChar; +end; + +function integerFromString(digits:KeywordString):integer; +var value,error:integer; +begin + val(digits, value, error); + if error <> 0 then + errorExit2('Invalid integer value', digits); + integerFromString := value; +end; + +function convertHex(var digits:KeywordString):integer; +var i,v,len:integer; + c:char; +begin + len := length(digits); + + i := 2; + convertHex := 0; + + while i <= len do + begin + convertHex := convertHex shl 4; + c := 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; + +function convertBin(var digits:KeywordString):integer; +var i,v,len:integer; + c:char; +begin + len := length(digits); + + i := 2; + convertBin := 0; + + while i <= len do + begin + c := digits[i]; + if c <> '_' then (* ignore '_' for a syntax like 0000_0001 *) + begin + convertBin := convertBin shl 1; + + if (c >= '0') and (c <= '1') then + v := ord(c) - ord('0') + else + errorExit2('Invalid number',digits); + + convertBin := convertBin + v; + end; + i := i + 1; + end; +end; + +function convertChar(digits:KeywordString):integer; +begin + convertChar := ord(digits[1]); +end; + +function convertNumber(digits:KeywordString):integer; +var negate:boolean; +begin + negate := digits[1] = '-'; + (* we need to keep the sign for decimals + because we cannot represent abs(-maxint) + as a signed 32-bit integer and integerFromString + uses val() *) + if negate then + if (digits[2] in [ '$', '%' ]) then + delete(digits,1,1); + + if digits[1] = '$' then + convertNumber := convertHex(digits) + else + if digits[1] = '%' then + convertNumber := convertBin(digits) + else + begin + negate := false; + convertNumber := integerFromString(digits); + end; + if negate then + convertNumber := -convertNumber; +end; + +function getCharLitValue(tokenText:string):integer; +begin + (* is is a one-character-string-literal like 'A' ? *) + if length(tokenText) = 1 then + getCharLitValue := ord(tokenText[1]) + else + errorExit2('Cannot use string as char here', tokenText); +end; + +(* scan for an integer number. the first digit is already in curChar. + digits are written to keyword. *) +procedure getDigits(curChar: char; var keyword: KeywordString); +begin + keyword := keyword + curChar; + while peekChar in [ '0'..'9' ] do + begin + keyword := keyword + nextChar; + 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; + +(* Scan for an integer number in hexadecimal format. + The hex marker '$' is already in curChar. + Digits are written to keyword. *) +procedure getHexDigits(curChar: char; var keyword: KeywordString); +begin + keyword := keyword + curChar; + while peekChar in [ '0'..'9', 'A'..'F' ] do + begin + keyword := keyword + nextChar; + end; +end; + +procedure getToken(var tokenReturn:Token;stringTokens:boolean); +var curChar,pkChar: char; + keyword: KeywordString; + startLine: string[12]; + +function isKeywordChar(ch:char):boolean; +begin + isKeywordChar := (ch >= 'A') and (ch <= 'Z') or + (ch >= 'a') and (ch <= 'z') or + (ch >= '0') and (ch <= '9') or + (ch = '_') or (ch = '.'); +end; + +function isAlpha(ch:char):boolean; +begin + isAlpha := ((ch >= 'A') and (ch <= 'Z')) or + ((ch >= 'a') and (ch <= 'z')); +end; + +function isKeywordStart(ch:char):boolean; +begin + isKeywordStart := ((ch >= 'A') and (ch <= 'Z')) or + ((ch >= 'a') and (ch <= 'z')) or + (ch = '_'); +end; + +begin + curChar := nextChar; + + tokenReturn.tokenText := curChar; + + if curChar = shortcutChar then (* two character instruction shortcut *) + begin + keyword := curChar + nextChar; + + (* shortcuts can have modifiers *) + while isKeywordChar(peekChar) do + begin + curChar := Upcase(nextChar); + if (length(keyword) < 80) and (curChar <> #0) then keyword := keyword + curChar; + end; + + tokenReturn.tokenKind := KeywordToken; + tokenReturn.tokenText := keyword; + end + else + if curChar = #0 then + tokenReturn.tokenKind := EOFToken + else + if curChar = #10 then + tokenReturn.tokenKind := EOLToken + else + if curChar = '+' then + tokenReturn.tokenKind := PlusToken + else + if curChar = '-' then + tokenReturn.tokenKind := MinusToken + else + if curChar = '*' then + tokenReturn.tokenKind := AsteriskToken + else + if curChar = '/' then + tokenReturn.tokenKind := SlashToken + else + if curChar = '~' then + tokenReturn.tokenKind := TildeToken + else + if curChar = '@' then + tokenReturn.tokenKind := AtToken + else + if curChar = ',' then + tokenReturn.tokenKind := CommaToken + else + if curChar = '&' then + tokenReturn.tokenKind := AndToken + else + if curChar = '|' then + tokenReturn.tokenKind := OrToken + else + if curChar = '^' then + tokenReturn.tokenKind := XorToken + else + if curChar = '.' then + begin + pkChar := peekChar; + if isAlpha(pkChar) then + begin + keyword := Upcase(curChar); + while isKeywordChar(peekChar) do + begin + curChar := Upcase(nextChar); + if (length(keyword) < 80) and (curChar <> #0) then keyword := keyword + curChar; + end; + tokenReturn.tokenText := keyword; + tokenReturn.tokenKind := DirectiveToken; + end + else + tokenReturn.tokenKind := DotToken; + end + else + if curChar = '%' then + (* percent sign can be the start of a binary number or + an include directive *) + begin + pkChar := peekChar; + if pkChar in ['A'..'Z', 'a'..'z' ] then (* is it a meta directive? *) + begin + keyword := Upcase(curChar); + while peekChar in ['A'..'Z', 'a'..'z', '0'..'9', '_'] do + begin + curChar := Upcase(nextChar); + if (length(keyword) < 80) and (curChar <> #0) then keyword := keyword + curChar; + end; + tokenReturn.tokenText := keyword; + tokenReturn.tokenKind := MetaKeywordToken; + end + else + if pkChar in ['0'..'1' ] then (* is it a binary number? *) + begin + keyword := curChar; + while peekChar in ['0','1','_' ] do + begin + curChar := nextChar; + if (length(keyword) < 80) and (curChar <> #0) then keyword := keyword + curChar; + end; + tokenReturn.tokenText := keyword; + tokenReturn.tokenKind := NumberToken; + end + else + tokenReturn.tokenKind := PercentToken; (* this is most likely unusable *) + end + else + if curChar = ';' then + tokenReturn.tokenKind := SemicolonToken + else + if isKeywordStart(curChar) then + begin + keyword := Upcase(curChar); + while isKeywordChar(peekChar) do + begin + curChar := Upcase(nextChar); + if (length(keyword) < 80) and (curChar <> #0) then keyword := keyword + curChar; + end; + + tokenReturn.tokenText := keyword; + if peekChar = ':' then + begin + tokenReturn.tokenKind := LabelToken; + curChar := nextChar; + end + else + tokenReturn.tokenKind := KeywordToken; + end + else + if isdigit(curChar) then + begin + keyword := ''; + getDigits(curChar, keyword); + tokenReturn.tokenText := keyword; + tokenReturn.tokenKind := NumberToken; + end + else + if curChar = '$' then + begin + keyword := ''; + getHexDigits(curChar, keyword); + tokenReturn.tokenText := keyword; + tokenReturn.tokenKind := NumberToken; + end + else + if (curChar = '''') and stringTokens then + begin + keyword := nextChar; + curChar := nextChar; + tokenReturn.tokenKind := CharLitToken; + tokenReturn.tokenText := keyword; + + if curChar <> '''' then + errorExit2('Invalid character literal, missing ''', keyword); + end + else + if (curChar = '"') and stringTokens then + begin + str(lineno, startLine); + keyword := ''; + curChar := nextChar; + (* add characters as long as the current char is not ' + (or if it is a double ') and not EOF *) + while (not ((curChar = '"') and (peekChar <> '"'))) and (curChar <> #0 ) do + begin + if (curChar = '"') and (peekChar = '"') then + begin + keyword := keyword + curChar; + curChar := nextChar; + end + else + keyword := keyword + curChar; + curChar := nextChar; + end; + if curChar = #0 then + errorExit2('Unterminated string constant starting at line', startLine); + tokenReturn.tokenText := keyword; + (* string literals with a length of 1 are char literals + which may be converted into string constants later *) + if length(keyword) = 1 then + tokenReturn.tokenKind := CharLitToken + else + tokenReturn.tokenKind := StringLitToken; + end + else + tokenReturn.tokenKind := UnknownToken; +end; + +(* check for (and do not consume) a specific token, returns true on match *) +function checkToken(kind: TokenType): boolean; +begin + checkToken := curToken.tokenKind = kind; +end; + +(* move to next token without any processing. + sets curToken global variable. *) +procedure skipToNextToken; +begin + getToken(nextToken, true); + curToken := nextToken; +end; + +(* read the next token into the global variable curToken. + skips whitespace and comments. +*) +procedure readNextToken; +var c:char; +begin + skipWhitespace; + + lastToken := curToken; + getToken(nextToken, true); + + curToken := nextToken; + + if curToken.tokenKind = SemicolonToken then + begin + repeat + c := nextChar; + until c = #10; + curToken.tokenKind := EOLToken; + end; +end; + +(* match (and consume) a token or exit with error *) +procedure matchToken(kind: TokenType); +begin + if curToken.tokenKind <> kind then + errorExit2('Expected ' + descToken(kind) + ', found', curToken.tokenText); + readNextToken; +end; + +(* match (and consume) a token, returning true, or if no match, do not + consume token and return false *) +function matchTokenOrNot(wantedToken: TokenType): boolean; +begin + if checkToken(wantedToken) then + begin + matchTokenOrNot := true; + readNextToken; + end + else + matchTokenOrNot := false; +end; + +procedure emitInstructionWord(value:InstructionWord); forward; +procedure fixupLabel(oldPc, newPc:integer); forward; + +procedure alignOutput(amount:integer); +var mask,o:integer; + oldPc:integer; +begin + oldPc := pc; + mask := amount - 1; + + o := pc and mask; + if o = 2 then + begin + emitInstructionWord(0); + (* if there was a label, we need to fix the address *) + fixupLabel(oldPc, pc); + end + else + if o = 0 then + begin (* do nothing *) end + else + errorExit2('internal error: bad alignment', ''); +end; + +procedure emitBinByte(value:integer); +var c:char; +begin + c := chr(value and $FF); + write(outfile,c); +end; + +procedure emitBin16(value:InstructionWord); +var hi,lo:integer; +begin + hi := value and $FF00 shr 8; + lo := value and $00FF; + emitBinByte(hi); + emitBinByte(lo); +end; + +procedure emitBin32(value:MachineWord); +var b3,b2,b1,b0:integer; +begin + b0 := value and $FF; + value := value shr 8; + b1 := value and $FF; + value := value shr 8; + b2 := value and $FF; + value := value shr 8; + b3 := value and $FF; + emitBinByte(b3); + emitBinByte(b2); + emitBinByte(b1); + emitBinByte(b0); +end; + +procedure emitAsciiBin(encoded:InstructionWord); +var i:integer; + digit:char; +begin + for i := 1 to 16 do + begin + if (encoded and $8000) <> 0 then + digit := '1' + else + digit := '0'; + + write(outfile, digit); + encoded := encoded shl 1; + end; + if((pc and 3) = 2) then + writeln(outfile); +end; + +(* assumes 32-bit alignment *) +procedure emitAsciiBin32(value:MachineWord); +var i:integer; + digit:char; +begin + for i := 1 to 32 do + begin + if (value and $80000000) <> 0 then + digit := '1' + else + digit := '0'; + + write(outfile, digit); + value := value shl 1; + end; + writeln(outfile); +end; + +procedure emitAsciiByte(value:integer); +var i:integer; + digit:char; +begin + for i := 1 to 8 do + begin + if (value and $80) <> 0 then + digit := '1' + else + digit := '0'; + + write(outfile, digit); + value := value shl 1; + end; + + if (pc and wordSizeMask) = 3 then + writeln(outfile); +end; + +(* + Emit a single byte. + Make sure to do proper alignment afterwards. + Mainly used for .BYTE directive. +*) +procedure emitByte(value:integer); +begin + if outputEnabled then + begin + if asciiOutput then + emitAsciiByte(value) + else + emitBinByte(value); + end; + bytesCount := bytesCount + 1; + pc := pc + 1; +end; + +(* assumes aligned output *) +procedure emitWord(value:MachineWord); +begin + if outputEnabled then + begin + if asciiOutput then + emitAsciiBin32(value) + else + emitBin32(value); + end; + bytesCount := bytesCount + 4; + pc := pc + 4; +end; + +procedure emitInstructionWord(value:InstructionWord); +begin + if outputEnabled then + begin + if asciiOutput then + emitAsciiBin(value) + else + emitBin16(value); + end; + bytesCount := bytesCount + 2; + pc := pc + 2; +end; + +procedure emitInstruction(var opcode:OpcodeData; encoded:InstructionWord); +begin + emitInstructionWord(encoded); +end; + +procedure emitBlock(count:integer; value:integer); +var i:integer; +begin + alignOutput(wordSize); + for i := 1 to count do + emitWord(value); +end; + +procedure encodeOperand(value:integer; var op:OpcodeData; var encoded:InstructionWord); forward; +procedure getBaseAndModifiers(var ins:KeywordString; var opcode:OpcodeData; var encoded:InstructionWord); forward; + +procedure encodeInstruction(ins:string; operand:integer; var encoded:InstructionWord); +var opcode:OpcodeData; +begin + getBaseAndModifiers(ins, opcode, encoded); + if opcode.id = LOADCPId then + errorExit2('internal error in encodeInstruction', curToken.tokenText); + encodeOperand(operand, opcode, encoded); +end; + +procedure ClearTree(var root:TreeRef); +begin + while root <> nil do + begin + (* delete subtrees first to reduce reshuffling of nodes *) + if root^.left <> nil then TreeDelete(root^.left, root^.left^.key^); + if root^.right <> nil then TreeDelete(root^.right, root^.right^.key^); + TreeDelete(root, root^.key^); + end; + verifyTree(root); +end; + +procedure ClearCPool; +var current:CPoolRef; + next:CPoolRef; +begin + current := constantPool; + + while current <> nil do + begin + next := current^.next; + dispose(current); + current := next; + end; + constantPool := nil; +end; + +procedure createSymbol(var keyword:IdentString; typ:SymbolType; value:integer; aligned,padded:boolean); + forward; +procedure dumpCPool; forward; + +procedure emitConstantPool(branch:boolean); +var current:CPoolRef; + labelname:IdentString; + value:KeywordString; + intValue:integer; + size:integer; + encoded:InstructionWord; + padded:boolean; +begin + (* writeln('*** emitConstantPool at ', pc, ' count ', cPoolCount); *) + if branch then + begin + (* calculate size of all constants in bytes *) + size := cPoolCount * wordSize; + + (* + Add padding if alignment is needed. + This happens when the pc is at a word boundary (pc and wordSize = 0). + Then after the branch instruction, the pc is at a half-word boundary + and we need a padding half-word to get the correct alignment for the + word-sized constants. + *) + if (pc and wordSizeMask) = 0 then size := size + insSize; + + (* encode the instruction, adjust operand for the size of the branch instruction*) + encodeInstruction('BRANCH', pc + size + insSize, encoded); + emitInstructionWord(encoded); + end; + + + current := constantPool; + padded := false; + + (* if the constant pool is empty, do no alignment *) + if current <> nil then + begin + (* remember if we needed alignment padding *) + padded := (pc and wordSizeMask) = insSize; + alignOutput(wordSize); + end; + + (* the cpool list has the latest entries at the front, + so go to the tail first and then go backward *) + if current <> nil then + while current^.next <> nil do + current := current^.next; + + while current <> nil do + begin + labelname := current^.labelname; + value := current^.value; + + createSymbol(labelname, LabelSymbol, pc, true, padded); + (* only the first entry is marked as padded *) + if padded then padded := false; + if current^.symbolic then + intValue := getSymbolValue(value) + else + intValue := convertNumber(value); + emitWord(intValue + current^.offset); + + current := current^.prev; + end; + + (* writeln('*** emitConstantPool new pc ', pc); *) + (* dumpCPool; *) + ClearCPool; + cPoolCount := 0; +end; + +procedure encodeOperand(value:integer; var op:OpcodeData; var encoded:InstructionWord); +var mask, negativeMask:integer; + valueStr:string; + isSigned:boolean; + min, max: integer; +begin + case op.operand of + NoOprnd: begin mask := 0; negativeMask := 0; end; + U13WOprnd: begin mask := $1FFE; negativeMask := $0000; end; + S13Oprnd: begin mask := $1FFF; negativeMask := $1000; end; + RelWOprnd: begin mask := $1FFE; negativeMask := $1000; value := value - pc; end; + S10Oprnd: begin mask := $03FF; negativeMask := $0200; end; + U4Oprnd: begin mask := $000F; negativeMask := $0000; end; + CmpOprnd: begin mask := $000F; negativeMask := $0000; end; + RegOprnd: begin mask := $000F; negativeMask := $0000; end; + RelU10Oprnd: begin mask := $03FF; negativeMask := $0000; value := value - pc; end; + OptOprnd: begin mask := $000F; negativeMask := $0000; end; + end; + + isSigned := negativeMask <> 0; + + if isSigned then + begin + min := -negativeMask; + max := -min + 1; + end + else + begin + min := 0; + max := mask; + end; + + if (value < min) or (value > max) then + begin + (* if not on the last pass (generating output), + we ignore values which are out of range, + because they might change after the 1st pass *) + + if not outputEnabled then + value := 0 + else + begin + if op.operand = RelU10Oprnd then + begin + writeln; + writeln('bad RelU10Oprnd:', value, ' pc:', pc, ' pass:', pass); + dumpCPool; + end; + str(value, valueStr); + errorExit2('Invalid operand value', valueStr); + end; + end; + + encoded := (encoded and not mask) or (value and mask); +end; + +function getSymbol(var keyword:KeywordString):TreeDataRef; +begin + getSymbol := TreeSearch(symbolTable, keyword); + if (getSymbol = nil) and (pass > 1) then + errorExit2('Undeclared symbol', keyword); +end; + +function getLabelAddr(var keyword:KeywordString):integer; +var sym:TreeDataRef; +begin + sym := getSymbol(curToken.tokenText); + + if sym = nil then + getLabelAddr := Unresolved + else + getLabelAddr := sym^.symboldata.value; +end; + +function findSymbol(var keyword:KeywordString):TreeDataRef; +begin + findSymbol := TreeSearch(symbolTable, keyword); +end; + +function getSymbolValue(var keyword:KeywordString):integer; +var data:TreeDataRef; +begin + data := TreeSearch(symbolTable, keyword); + + if (data = nil) then + begin + if pass = 1 then + (* in pass 1, we do not care about undefined symbols *) + getSymbolValue := Unresolved + else + errorExit2('Undeclared symbol', keyword); + end + else + getSymbolValue := data^.symboldata.value; +end; + +procedure addUncertainLabel(var name:IdentString); +var current:UnresBranchRef; + newLListEntry:LabelListRef; +begin + current := firstUnresBranch; + + while (current <> nil) do + begin + (* writeln('**addUncertainLabel ',name, ' for unresBranch ', current^.target); *) + (* put new label list entry at head of the list *) + new(newLListEntry); + newLListEntry^.next := current^.labels; + newLListEntry^.prev := nil; + newLListEntry^.name := name; + if current^.labels <> nil then + current^.labels^.prev := newLListEntry; + current^.labels := newLListEntry; + + current := current^.next; + end; +end; + +procedure addUnresBranch(var name:IdentString; origin:integer; maxDistance,shrink:integer); +var newUnresBranch:^UnresolvedBranch; +begin + new(newUnresBranch); + newUnresBranch^.target := name; + newUnresBranch^.origin := origin; + newUnresBranch^.maxDistance := maxDistance; + newUnresBranch^.shrinkage := shrink; + newUnresBranch^.labels := nil; + newUnresBranch^.next := firstUnresBranch; + firstUnresBranch := newUnresBranch; + + (* writeln('** addUnresBranch ', name, ' at ', origin); *) +end; + +(* Delete unresolved branch entry with target *name*. + Will delete multiple occurrences of the same name. *) +procedure deleteUnresBranch(var name:IdentString); +var last,current,temp:^UnresolvedBranch; +begin + current := firstUnresBranch; + last := nil; + + while (current <> nil) do + begin + if current^.target = name then + begin + if last = nil then + firstUnresBranch := current^.next + else + last^.next := current^.next; + temp := current^.next; + dispose(current); + current := temp; + end + else + begin + last := current; + current := current^.next; + end; + end; +end; + +procedure addUnresBranch2(var name:IdentString; o:integer; max,shrink:integer); +var newUnresBranch:^UnresolvedBranch; +begin + new(newUnresBranch); + with newUnresBranch^ do + begin + target := name; + origin := o; + maxDistance := max; + shrinkage := shrink; + labels := nil; + next := firstUnresBranch; + end; + firstUnresBranch := newUnresBranch; +end; + +(* Check if a label declaration resolves an unresolved branch + (.LBRANCH/.LCBRANCH). If it does, apply the code size correction + to all labels we encountered since the branch. *) +procedure checkUnresBranches(var name:IdentString); +var r:UnresBranchRef; + current,last,next:LabelListRef; + sym:TreeDataRef; + distance:integer; + shrink:boolean; + adjustment:integer; +begin + r := firstUnresBranch; + + while r <> nil do + begin + if r^.target = name then + begin + distance := pc - r^.origin; + shrink := distance <= r^.maxDistance; +{ writeln('** checkUnresBranches found ', name, ' at ', pc, ' distance ', pc - r^.origin, ' line ', lineno); + writeln(' ', r^.origin, ' ', r^.maxDistance, ' ', r^.shrinkage); } + current := r^.labels; + last := nil; + + if shrink then + pc := pc - r^.shrinkage; + (* writeln(' short:', shrink); *) + + while current <> nil do + begin + (* go through all labels we encountered since the LBRANCH/LCBRANCH, + process and dispose of the list entries *) + + (* writeln(' ', current^.name); *) + + if shrink then + begin + sym := findSymbol(current^.name); + with sym^.symboldata do + begin + (* writeln(' ', value, ' -', r^.shrinkage, ' ', aligned, ' ', padded); *) + value := value - r^.shrinkage; + (* writeln(' ', value); *) + end; + end; + last := current; + current := current^.next; + end; + + (* walk through list backwards to check alignment, + that is in order of occurrence *) + adjustment := 0; + current := last; + while current <> nil do + begin + if shrink then + begin + sym := findSymbol(current^.name); + with sym^.symboldata do + begin + if aligned then + begin + (* if this label needs alignment, shift all labels + after this one by one instruction word (2 bytes) *) + if ((value + adjustment) and wordSizeMask) = insSize then + begin + (* if a constant pool entry was already padded, + do not add second padding but remove first + padding instead *) + if not padded then + begin + padded := true; + pc := pc + insSize; + adjustment := adjustment + insSize; + end + else + begin + padded := false; + pc := pc - insSize; + adjustment := adjustment - insSize; + end; + end; + end; + value := value + adjustment; + (* if adjustment <> 0 then + writeln(' ', current^.name, ' adjusted to ', value, ' by ', adjustment); *) + end; + end; +{$ifndef FPC} + {writeln(' disposing ', current^.name, ' ', current);} +{$endif} + next := current^.prev; + dispose(current); + current := next; + end; + r^.labels := nil; + end; + r := r^.next; + end; + deleteUnresBranch(name); +end; + +(* Create a symbol table entry. + On passes other than 1, symbol must exist and the value is updated. *) +procedure createSymbol(var keyword:IdentString; typ:SymbolType; value:integer; aligned, padded:boolean); +var d:TreeData; + dref:TreeDataRef; +begin + dref := TreeSearch(symbolTable, keyword); + + if pass = 1 then + begin + if dref <> nil then + errorExit2('Duplicate label', keyword); + d.typ := TDSymbol; + d.symboldata.typ := typ; + d.symboldata.value := value; + d.symboldata.aligned := aligned; + d.symboldata.padded := padded; + d.symboldata.exported := false; + TreeInsert(symbolTable, keyword, d); + + addUncertainLabel(keyword); + checkUnresBranches(keyword); + end + else + begin + if dref = nil then + begin + dumpCPool; + ErrorExit2('internal error in createSymbol', keyword); + end; + + if dref^.symboldata.value <> value then + (* writeln('////// label changed value ', keyword, ' ', + dref^.symboldata.value, ' -> ', value); *) + dref^.symboldata.value := value; + end; +end; + +(* Change the address of a label after it has been + created. This happens if an alignment is required + e.g. for a .WORD directive which has a label *) +procedure fixupLabel(oldPc, newPc:integer); +var current:TreeRef; + walkState:TreeWalkState; +begin + TreeWalkFirst(symbolTable, walkState, current); + while current <> nil do + begin + if current^.data^.symboldata.value = oldPc then + begin + current^.data^.symboldata.aligned := true; + current^.data^.symboldata.value := newPc; + current^.data^.symboldata.padded := (newPc <> oldPc); + + (* if newPc <> oldPc then + writeln(' aligning ', current^.key^, ' ', oldPc, ' -> ', newPc); *) + end; + TreeWalkNext(walkState, current); + end; +end; + +function parsePrimary:integer; +var applyNot:boolean; + negate:boolean; + value:integer; +begin + if checkToken(TildeToken) then + begin + readNextToken; + applyNot := true; + end + else + applyNot := false; + + if checkToken(MinusToken) then + begin + readNextToken; + negate := true; + end + else + negate := false; + + if checkToken(NumberToken) then + begin + (* let convertNumber handle negative numbers + because the statement + "value := -value" below would + not work for -maxint. + abs(-maxint) cannot be represented + as a signed 32-bit integer *) + if negate then + begin + value := convertNumber('-' + curToken.tokenText); + negate := false; + end + else + value := convertNumber(curToken.tokenText); + end + else + if checkToken(KeywordToken) then + value := getSymbolValue(curToken.tokenText) + else + if checkToken(CharLitToken) then + value := convertChar(curToken.tokenText) + else + if checkToken(AtToken) then + value := pc + else + errorExit2('number or symbol expected, got', descToken(curToken.tokenKind)); + + if applyNot then + value := not value; + + if negate then + value := - value; + + readNextToken; + + parsePrimary := value; +end; + +function parseExpression:integer; +var value:integer; + +function parseNextPrimary:integer; +begin + readNextToken; + parseNextPrimary := parsePrimary(); +end; + +begin + value := parsePrimary; + + while not (curToken.tokenKind in [ EOLToken, CommaToken ]) do + begin + if checkToken(PlusToken) then + value := value + parseNextPrimary + else + if checkToken(MinusToken) then + value := value - parseNextPrimary + else + if checkToken(AsteriskToken) then + value := value * parseNextPrimary + else + if checkToken(AndToken) then + value := value and parseNextPrimary + else + if checkToken(OrToken) then + value := value or parseNextPrimary + else + if checkToken(XorToken) then + value := value xor parseNextPrimary + else + if checkToken(SlashToken) then + value := value div parseNextPrimary + else + errorExit2('Expected one of + - * / & | ^ but got', curToken.tokenText); + end; + + parseExpression := value; +end; + +procedure parseLabel; +begin + (* writeln(':::: parseLabel ', curToken.tokenText, ' at ', pc); *) + createSymbol(curToken.tokenText, LabelSymbol, pc, false, false); + + readNextToken; +end; + +procedure parseOneWordArg; +var operandValue:integer; +begin + operandValue := parseExpression; + emitWord(operandValue); +end; + +procedure parseWordArgs; +begin + alignOutput(wordSize); + parseOneWordArg; + while checkToken(CommaToken) do + begin + readNextToken; + (* if there is a comma at the end of the line, + continue to the next line *) + if checkToken(EOLToken) then + readNextToken; + + parseOneWordArg; + end; +end; + +procedure parseOneByteArg; +var bytevalue:integer; + c:char; +begin + if checkToken(StringLitToken) then + begin + for c in curToken.tokenText do + emitByte(ord(c)); + readNextToken; + end + else + begin + bytevalue := parseExpression; + emitByte(byteValue); + end; +end; + +procedure parseByteArgs; +begin + alignOutput(wordSize); + parseOneByteArg; + while checkToken(CommaToken) do + begin + readNextToken; + (* if there is a comma at the end of the line, + continue to the next line *) + if checkToken(EOLToken) then + readNextToken; + + parseOneByteArg; + end; + + (* align to word *) + while (pc and wordsizeMask) <> 0 do + emitByte(0); +end; + +procedure dumpOpcodeTable; +var walkState:TreeWalkState; + walkRes:TreeRef; +begin + writeln('Opcode Table:'); + TreeWalkStart(opcodeTable, walkState); + repeat + TreeWalkNext(walkState, walkRes); + if walkRes <> nil then + writeln(walkRes^.key^); + until walkRes = nil; +end; + +function changeFileSuffix(filename: string; suffix:string): string; forward; + +procedure writeSymbolTable; +var walkState:TreeWalkState; + walkRes:TreeRef; + h:string; + f:SymFileType; + fname:string; + c:char; +begin + fname := changeFileSuffix(filename, SymFileSuffix); + overwriteFile(f, fname); + + TreeWalkStart(symbolTable, walkState); + repeat + TreeWalkNext(walkState, walkRes); + if walkRes <> nil then + begin + if walkRes^.data^.symboldata.typ in [ LabelSymbol, ConstSymbol ] then + begin + hexstr(walkRes^.data^.symboldata.value, h); + if walkRes^.data^.symboldata.typ = ConstSymbol then + c := '=' + else + if walkRes^.data^.symboldata.exported then + c := '!' + else + c := ' '; + writeln(f, h, ' ', c, walkRes^.key^); + end; + end; + until walkRes = nil; + close(f); +end; + +procedure dumpSymbolTable; +var walkState:TreeWalkState; + walkRes:TreeRef; + h:string; +begin + writeln('Symbol Table:'); + TreeWalkStart(symbolTable, walkState); + repeat + TreeWalkNext(walkState, walkRes); + if walkRes <> nil then + begin + if walkRes^.data^.symboldata.typ = LabelSymbol then + begin + hexstr(walkRes^.data^.symboldata.value, h); + writeln(h, ' ', walkRes^.key^); + end; + end; + until walkRes = nil; +end; + +procedure dumpCPool; +var current:CPoolRef; +begin + writeln('dump constant pool ', cPoolCount, ' ', nextConstId); + + current := constantPool; + + while current <> nil do + begin + writeln(current^.labelname, ': ', current^.value, ' ', + getSymbolValue(current^.labelname), ' '); + current := current^.next; + end; +end; + +procedure emitLoadcp(var operand:KeywordString; numOffset:integer); +var cpooladdr:integer; + encoded:InstructionWord; +begin + cpooladdr := getCPoolAddr(operand, numOffset); + (* writeln('** emitLoadcp for ',operand, '/', numOffset, ' ', cpooladdr); *) + encodeInstruction('LOADREL', cpooladdr, encoded); + emitInstructionWord(encoded); +end; + +procedure parseLoadcp; +var opstr:KeywordString; + data:TreeDataRef; + numOffset:integer; +begin + if not (curToken.tokenKind in [ KeywordToken, NumberToken, MinusToken ]) then + errorExit2('Identifier or number expected, got', curToken.tokenText); + + if checkToken(MinusToken) then + begin + opstr := '-'; + readNextToken; + if not checkToken(NumberToken) then + errorExit2('Invalid number', curToken.tokenText); + opstr := opstr + curToken.tokenText; + end + else + opstr := curToken.tokenText; + + readNextToken; + + (* check for optional offset *) + if checkToken(CommaToken) then + begin + readNextToken; + (* offset can be either a number literal *) + if checkToken(NumberToken) then + numOffset := convertNumber(curToken.tokenText) + else + (* or a symbol *) + if checkToken(KeywordToken) then + begin + data := findSymbol(curToken.tokenText); + if data = nil then + errorExit2('Cannot use unresolved symbol for LOADCP offset:', + curToken.tokenText); + numOffset := data^.symboldata.value; + end + else + errorExit2('Number or symbol required, got', curToken.tokenText); + readNextToken; + end + else + numOffset := 0; + + emitLoadcp(opstr, numOffset); +end; + +procedure parseLbranch; +var value:integer; + distance:integer; + offset,shrinkage:integer; + pad:boolean; + encoded:InstructionWord; +begin + if not checkToken(KeywordToken) then + errorExit2('identifier expected, got', curToken.tokenText); + + value := getLabelAddr(curToken.tokenText); + + distance := value - pc; + if (value = Unresolved) or (distance > 4095) or (distance < -4096) then + begin + if (pc and 3) = 0 then (* no padding *) + begin + pad := false; + (* total size 8 bytes *) + offset := 4; (* offset for LOADREL *) + shrinkage := 6; (* difference to short form size *) + end + else + begin + pad := true; + (* total size 10 bytes *) + offset := 6; (* offset for LOADREL with padding *) + shrinkage := 8; (* difference to short form size *) + end; + if value = Unresolved then + addUnresBranch(curToken.tokenText, pc, 4095, shrinkage); + + encodeInstruction('LOADREL', pc + offset, encoded); + emitInstructionWord(encoded); + + encodeInstruction('JUMP', 0, encoded); + emitInstructionWord(encoded); + + if pad then + emitInstructionWord(0); + emitWord(value); + end + else + begin + encodeInstruction('BRANCH', value, encoded); + emitInstructionWord(encoded); + end; + + (* + if value = Unresolved then + writeln('** parseLbranch ', curToken.tokenText, ' unresolved') + else + if (distance > 4095) then + writeln('** parseLbranch ', curToken.tokenText, ' long ', distance) + else + writeln('** parseLbranch ', curToken.tokenText, ' short ', distance); + *) + + readNextToken; +end; + +procedure parseLcbranch(negate:boolean); +var value:integer; + relValue:integer; + offset,shrinkage:integer; + encoded:InstructionWord; + modifier:string[4]; + pad:boolean; +begin + if not checkToken(KeywordToken) then + errorExit2('identifier expected, got', curToken.tokenText); + + value := getLabelAddr(curToken.tokenText); + + relValue := value - pc; + + modifier := ''; + + if (value = Unresolved) or (relValue > 4095) or (relValue < -4096) then + begin + if (pc and 3) = 2 then (* no padding *) + begin + pad := false; + (* total size 10 bytes *) + offset := 4; (* offset for LOADREL *) + shrinkage := 8; (* difference to short form size *) + end + else + begin + pad := true; + (* total size 12 bytes *) + offset := 6; (* offset for LOADREL with padding *) + shrinkage := 10; (* difference to short form size *) + end; + + if value = Unresolved then + addUnresBranch(curToken.tokenText, pc, 4095, shrinkage); + + (* writeln('*** long cbranch triggered:', value, ' ', relValue, ' pass:',pass); + writeln('*** pc ', pc, ' offset ', offset, ' insSize ', insSize); + writeln('*** ', pc + offset + insSize); *) + if not negate then + modifier := '.Z'; + (* branch over CBRANCH, LOADREL, padding and literal value *) + encodeInstruction('CBRANCH' + modifier, pc + insSize + offset + wordSize, encoded); + emitInstructionWord(encoded); + + encodeInstruction('LOADREL', pc + offset, encoded); + emitInstructionWord(encoded); + + encodeInstruction('JUMP', 0, encoded); + emitInstructionWord(encoded); + + if pad then + emitInstructionWord(0); + emitWord(value); + end + else + begin + if negate then + modifier := '.Z'; + encodeInstruction('CBRANCH' + modifier, value, encoded); + emitInstructionWord(encoded); + end; + + readNextToken; +end; + +procedure parseDirective; +var operandValue:integer; + count:integer; + name:IdentString; + oldsym:TreeDataRef; +begin + readNextToken; + + if lastToken.tokenText = '.LBRANCH' then + parseLbranch + else + if lastToken.tokenText = '.LCBRANCH' then + parseLcbranch(false) + else + if lastToken.tokenText = '.LCBRANCHZ' then + parseLcbranch(true) + else + if lastToken.tokenText = '.ORG' then + begin + operandValue := parseExpression; + pc := operandValue; + end + else + if lastToken.tokenText = '.EQU' then + begin + matchToken(KeywordToken); + name := lastToken.tokenText; + operandValue := parseExpression; + + oldsym := findSymbol(name); + if oldsym <> nil then + begin + if oldsym^.symboldata.value <> operandValue then + errorExit2('Symbol already declared:', name); + end + else + createSymbol(name, ConstSymbol, operandValue, false, false); + end + else + if lastToken.tokenText = '.WORD' then + parseWordArgs + else + if lastToken.tokenText = '.BYTE' then + parseByteArgs + else + if lastToken.tokenText = '.CPOOL' then + emitConstantPool(false) + else + if lastToken.tokenText = '.CPOOLNOP' then + emitConstantPool(true) + else + if lastToken.tokenText = '.BLOCK' then + begin + count := parseExpression; + if matchTokenOrNot(CommaToken) then + operandValue := parseExpression + else + operandValue := 0; + emitBlock(count, operandValue); + end + else + errorExit2('Unrecognized directive', lastToken.tokenText); +end; + +procedure parseMetaDirective; +var filename:string; + sym:TreeDataRef; +begin + readNextToken; + if lastToken.tokenText = '%INCLUDE' then + begin + if curToken.tokenKind in [StringLitToken, KeywordToken] then + begin + filename := curToken.tokenText; + readNextToken; + beginInclude(filename); + end + else + errorExit2('Filename expected', ''); + end + else + if lastToken.tokenText = '%EXPORT' then + begin + if curToken.tokenKind = KeywordToken then + begin + sym := findSymbol(curToken.tokenText); + if sym = nil then + errorExit2('Undeclared symbol', curToken.tokenText); + sym^.symboldata.exported := true; + end + else + errorExit2('Symbol expected', ''); + readNextToken; + end + else + errorExit2('Invalid meta directive', lastToken.tokenText); +end; + +procedure encode(var entry:EncodingEntry; var value:InstructionWord); +begin + value := (value and not entry.mask) or entry.value; +end; + +procedure getModifier(var m:KeywordString; var opcode:OpcodeData; var encoded:InstructionWord); +var cur:^ModifierEntry; +begin + if opcode.id <> 0 then + begin + cur := opcode.modifiers; + while cur <> nil do + begin + if m = cur^.keyword then + begin + encode(cur^.encoding, encoded); + break; + end; + cur := cur^.next; + end; + if cur = nil then + errorExit2('Invalid modifier', m); + end; +end; + +procedure getMnemonic(var m:KeywordString; var opcode:OpcodeData; var encoded:InstructionWord); +var data:TreeDataRef; + ch:char; +begin + if m[1] = shortcutChar then + begin + ch := m[2]; + if (ch < firstShCChar) or (ch > lastShCChar) then + errorExit2('invalid shortcut', m); + opcode := shortcuts[ch]; + if opcode.id = -1 then + errorExit2('invalid shortcut', m); + encode(opcode.encoding, encoded); + end + else + begin + data := TreeSearch(opcodeTable, m); + if data = nil then + begin + errorExit2('Unrecognized instruction', m); + opcode.id := 0; + end + else + begin + opcode := data^.opcodedata; + encode(opcode.encoding, encoded); + end; + end; +end; + +procedure getBaseAndModifiers(var ins:KeywordString; var opcode:OpcodeData; var encoded:InstructionWord); +var i:integer; + insLength:integer; + slice:string; + startPos:integer; + +function scanchar(c:char; curPos:integer):integer; +begin + scanchar := 0; + + while curPos <= insLength do + begin + if ins[curPos] = c then + begin + scanchar := curPos; + break; + end + else + curPos := curPos + 1; + end; +end; + +begin + encoded := 0; + insLength := length(ins); + + i := pos('.',ins); + + { writeln('** getModifiers ',i); } + + if i > 1 then + begin + slice := copy(ins,1,i-1); + getMnemonic(slice, opcode, encoded); + repeat + startPos := i + 1; + i := scanchar('.', startPos); + if i > 0 then + begin + slice := copy(ins,startPos,i-startPos); + getModifier(slice, opcode, encoded); + end; + until i < 1; + + (* last slice *) + slice := copy(ins, startPos, insLength-startPos+1); + getModifier(slice, opcode, encoded); + end + else + getMnemonic(ins, opcode, encoded); +end; + +procedure parseInstruction; +var operandValue:integer; + opcode:OpcodeData; + encodedIns:InstructionWord; +begin + getBaseAndModifiers(curToken.tokenText, opcode, encodedIns); + + readNextToken; + + if opcode.id = LOADCPId then + parseLoadcp + else + begin + if opcode.operand <> NoOprnd then + begin + if not checkToken(EOLToken) then + operandValue := parseExpression + else + begin + if opcode.operand = OptOprnd then + operandValue := 0 + else + errorExit2('Missing operand', lastToken.tokenText) + end + end + else + operandValue := 0; + + encodeOperand(operandValue, opcode, encodedIns); + emitInstruction(opcode, encodedIns); + end; +end; + +procedure parseLine; +begin + (* writeln('## P', pass, ' line ', lineno:4, ' pc ', pc:8); *) + + if checkToken(LabelToken) then + parseLabel; + + if checkToken(DirectiveToken) then + parseDirective + else + if checkToken(KeywordToken) then + parseInstruction + else + if checkToken(MetaKeywordToken) then + parseMetaDirective + else + if checkToken(EOLToken) then + begin end (* empty line *) + else + begin + (* writeln(curToken.tokenKind); *) + errorExit2('Invalid syntax', curToken.tokenText); + end; + + matchToken(EOLToken); +end; + +procedure parseFile; +begin + readNextToken; + repeat + parseLine; + if (lineno and progressSteps) = 0 then + printCurrentLineno; + until checkToken(EOFToken); + emitConstantPool(false); +end; + +(* Add an instruction to the opcodeTable (which is a tree). + mask specifies the bits which are used by the opcode. +*) +procedure addOpcode(mnemonic:InsString; value, mask:integer; oprnd: OperandType); +var data:TreeData; + +begin + data.typ := TDOpcode; + data.opcodedata.encoding.value := value; + data.opcodedata.encoding.mask := mask; + data.opcodedata.modifiers := nil; + data.opcodedata.operand := oprnd; + data.opcodedata.id := nextOpcodeId; + + nextOpcodeId := nextOpcodeId + 1; + + TreeInsert(opcodeTable, mnemonic, data); + + lastOpcode := TreeSearch(opcodeTable, mnemonic); +end; + +(* Add a modifier to the instruction that was last added by addOpcode. + mask specifies the bits used by the modifier. +*) +procedure addModifier(key:InsString; value, mask:integer); +var newModifier:^ModifierEntry; + cur:^ModifierEntry; +begin + if lastOpcode = nil then + errorExit2('internal error in addModifier', key); + + new(newModifier); + newModifier^.keyword := key; + newModifier^.encoding.value := value; + newModifier^.encoding.mask := mask; + newModifier^.next := nil; + + + cur := lastOpcode^.opcodedata.modifiers; + if cur = nil then + begin + lastOpcode^.opcodedata.modifiers := newModifier + end + else + begin + while cur^.next <> nil do cur := cur^.next; + cur^.next := newModifier; + end; +end; + +procedure addAlias(key:InsString; dest:InsString); +var opcode:OpcodeData; + encoded:InstructionWord; +begin + (* encode the instruction and modifiers *) + getBaseAndModifiers(dest, opcode, encoded); + (* add a new opcode entry with the alias name and + the values we just calculated *) + addOpcode(key, encoded, opcode.encoding.mask, opcode.operand); + (* copy the modifier list (list of valid modifiers) + from the original instruction *) + lastOpcode^.opcodedata.modifiers := opcode.modifiers; +end; + +procedure addShortcut(ch:char; dest:InsString); +var opcode:OpcodeData; + encoded:InstructionWord; +begin + if shortcuts[ch].id <> -1 then + errorExit2('internal error in addShortcut for', dest); + + getBaseAndModifiers(dest, opcode, encoded); + shortcuts[ch] := opcode; +end; + +procedure addSpecialOperand(key:IdentString; value:integer); +begin + createSymbol(key, SpecialSymbol, value, false, false) +end; + +procedure initSpecialOperands; +begin + pass := 1; (* createSymbol only creates symbols on pass 1 *) + + (* create special operand symbols *) + addSpecialOperand('FP', 0); + addSpecialOperand('BP', 1); + addSpecialOperand('RP', 2); + addSpecialOperand('IV', 3); + addSpecialOperand('IR', 4); + addSpecialOperand('ESP', 5); + addSpecialOperand('EQ', 2); + addSpecialOperand('LT', 1); + addSpecialOperand('NE', 6); + addSpecialOperand('LE', 3); + addSpecialOperand('GE', 5); + addSpecialOperand('GT', 7); +end; + +procedure initOpcodes; +begin + addOpcode('BRANCH', $0000, $E000, RelWOprnd); + + addOpcode('LOADC', $C000, $E000, S13Oprnd); + + addOpcode('LOAD', $8000, $E000, U13WOprnd); + addModifier('B', $0001, $0001); + + addOpcode('STORE', $4000, $E000, U13WOprnd); + addModifier('B', $0001, $0001); + + addOpcode('CBRANCH',$A001, $E001, RelWOprnd); + addModifier('N', $0001, $0001); + addModifier('NZ', $0001, $0001); + addModifier('Z', $0000, $0001); + + addOpcode('XFER', $6000, $E000, NoOprnd); + addModifier('RSM1', $0300, $0300); + addModifier('RS0', $0000, $0300); + addModifier('RS1', $0100, $0300); + addModifier('R2P', $0080, $0080); + addModifier('P2R', $0040, $0040); + addModifier('SM1', $0030, $0030); + addModifier('S0', $0000, $0030); + addModifier('S1', $0010, $0030); + addModifier('X2P', $0001, $0001); + + addOpcode('ALU', $2000, $E000, OptOprnd); + addModifier('SM1', $0030, $0030); + addModifier('S0', $0000, $0030); + addModifier('S1', $0010, $0030); + addModifier('X2Y', $0040, $0040); + addModifier('NX2Y', $0000, $0040); + addModifier('XT', $0080, $0080); + addModifier('ADD', $0000, $1e00); + addModifier('SUB', $0200, $1e00); + addModifier('NOT', $0400, $1e00); + addModifier('AND', $0600, $1e00); + addModifier('OR', $0800, $1e00); + addModifier('XOR', $0a00, $1e00); + addModifier('CMP', $0c00, $1e00); + addModifier('Y', $0e00, $1e00); + addModifier('SHR', $1000, $1e00); + addModifier('SHL', $1200, $1e00); + addModifier('INC', $1400, $1e00); + addModifier('DEC', $1600, $1e00); + addModifier('BPLC', $1a00, $1e00); + addModifier('BROT', $1c00, $1e00); + addModifier('BSEL', $1e00, $1e00); + addModifier('CMPU', $1800, $1e00); + + (* addOpcode('EXT', $E000, $E000); *) + + addOpcode('MEM', $E400, $FFF0, OptOprnd); + addModifier('W', $0200, $0200); + addModifier('SM1', $0030, $0030); + addModifier('S0', $0000, $0030); + addModifier('S1', $0010, $0030); + addModifier('X2Y', $0040, $0040); + addModifier('NX2Y', $0000, $0040); + + addOpcode('LOADREL',$F400, $FC00, RelU10Oprnd); + + LOADCPId := nextOpcodeId; + addOpcode('LOADCP', $F400, $FC00, RelU10Oprnd); + + addOpcode('REG', $E000, $FFF0, RegOprnd); + addModifier('W', $0200, $0200); + + addOpcode('FPADJ', $EC00, $FC00, S10Oprnd); + + addAlias('JUMP', 'XFER.SM1.X2P'); + addAlias('CALL', 'XFER.RS1.SM1.P2R.X2P'); + addAlias('RET', 'XFER.RSM1.R2P'); + addAlias('ADD', 'ALU.ADD.SM1'); + addAlias('SUB', 'ALU.SUB.SM1'); + addAlias('NOT', 'ALU.NOT.S0'); + addAlias('AND', 'ALU.AND.SM1'); + addAlias('OR', 'ALU.OR.SM1'); + addAlias('XOR', 'ALU.XOR.SM1'); + addAlias('CMP', 'ALU.CMP.SM1'); + addAlias('SHR', 'ALU.SHR.S0'); + addAlias('SHL', 'ALU.SHL.S0'); + addAlias('DUP', 'ALU.INC.S1.X2Y'); + addAlias('NIP', 'ALU.INC.SM1'); + addAlias('INC', 'ALU.INC.S0'); + addAlias('DEC', 'ALU.DEC.S0'); + addAlias('CMPU', 'ALU.CMPU.SM1'); + addAlias('BPLC', 'ALU.BPLC.SM1'); + addAlias('BROT', 'ALU.BROT.S0'); + addAlias('BSEL', 'ALU.BSEL.SM1'); + addAlias('Y', 'ALU.Y.S1.X2Y'); + addAlias('DROP', 'ALU.Y.SM1'); + addAlias('SWAP', 'ALU.Y.S0.X2Y'); + addAlias('OVER', 'ALU.Y.S1.X2Y'); + addAlias('LOADI', 'MEM'); + addAlias('STOREI', 'MEM.W.SM1'); + addAlias('LOADREG', 'REG'); + addAlias('STOREREG', 'REG.W'); +end; + +procedure initShortcuts; +var ch:char; +begin + for ch := firstShCChar to lastShCChar do + shortcuts[ch].id := -1; + + 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; + +function changeFileSuffix(filename: string; suffix:string): string; +var suffixPos:integer; +begin + suffixPos := pos(filenameSuffix, filename); + if suffixPos > 0 then + setlength(filename, suffixPos-1); + filename := filename + suffix; + changeFileSuffix := filename; +end; + +procedure performPass(passNo:integer); +begin + lineno := 1; + nextConstId := 0; + cPoolCount := 0; + pc := 0; + bytesCount := 0; + pass := passNo; + + outputEnabled := pass = 2; + + openFileWithDefault(infile, filename); + infileOpened := true; + + if outputEnabled then + overwriteFile(outfile, outfilename); + + parseFile; + printLastLineno; + + close(infile); + + if outputEnabled then + close(outfile); + + (* dumpSymbolTable; *) +end; + +procedure verifyNodeKey(node:TreeRef); +var c:integer; +begin + if node = nil then + errorExit2('verifyNodeKey FAIL node is nil', ''); + if node^.key = nil then + errorExit2('verifyNodeKey FAIL key is nil', ''); + + if length(node^.key^) < 1 then + errorExit2('verifyNodeKey FAIL key has zero length', ''); + + c := ord(node^.key^[1]); + + if not ( + ((c >= ord('0')) and (c <= ord('9'))) + or + ((c >= ord('A')) and (c <= ord('F'))) + ) then + begin + writeln('verifyNodeKey FAIL at ', node^.key^, ' ', c); + if node^.parent <> nil then + writeln(' parent:', node^.parent^.key^); + errorExit; + end; +end; + +procedure verifyTree(node:TreeRef); +begin + if node <> nil then + begin + verifyNodeKey(node); + + if node^.right <> nil then + begin + if node^.right^.parent <> node then + errorExit2('verifyTree FAIL parent check right at', node^.key^); + verifyTree(node^.right); + end; + + if node^.left <> nil then + begin + if node^.left^.parent <> node then + errorExit2('verifyTree FAIL parent check left at', node^.key^); + verifyTree(node^.left); + end; + end; +end; + +begin + infileOpened := false; + outputEnabled := false; + asciiOutput := false; + editOnError := false; + runOnSuccess := false; + buffered := false; + includeLevel := 0; + symbolTable := nil; + opcodeTable := nil; + lastOpcode := nil; + firstUnresBranch := nil; + + nextOpcodeId := 1; + + if ParamCount < 1 then halt; + + paramPos := 1; + filename := ''; + outfilename := ''; + + while paramPos <= ParamCount do + begin + if paramStr(paramPos) = '-e' then + editOnError := true + else + if paramStr(paramPos) = '-R' then + runOnSuccess := true + else + if paramStr(paramPos) = '-A' then + asciiOutput := true + else + begin + if length(filename) = 0 then + filename := ParamStr(paramPos) + else + outfilename := ParamStr(paramPos); + end; + paramPos := paramPos + 1; + end; + + initPlatform; + initOpcodes; + initSpecialOperands; + initShortcuts; + + if length(outfilename) = 0 then + begin + if asciiOutput then + outfilename := changeFileSuffix(filename, asciifileSuffix) + else + outfilename := changeFileSuffix(filename, outfileSuffix) + end; + + writeln('Assembling ', filename, ' to ', outfilename); + + performPass(1); + performPass(2); + + writeln(#13, lineno - 1, ' lines, program size ', bytesCount, ' bytes.'); + + (* dumpOpcodeTable; *) + (* dumpSymbolTable; *) + writeSymbolTable; + + if runOnSuccess then + ExecProgram(outfilename); +end. diff --git a/pcomp/sdis.pas b/pcomp/sdis.pas new file mode 100644 index 0000000..a07f0e2 --- /dev/null +++ b/pcomp/sdis.pas @@ -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(''); + 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(''); + 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(''); +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. diff --git a/pcomp/treeimpl.pas b/pcomp/treeimpl.pas new file mode 100644 index 0000000..599ec99 --- /dev/null +++ b/pcomp/treeimpl.pas @@ -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; diff --git a/pcomp/treetypes.pas b/pcomp/treetypes.pas new file mode 100644 index 0000000..116b97f --- /dev/null +++ b/pcomp/treetypes.pas @@ -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; diff --git a/progs/dumpdir.pas b/progs/dumpdir.pas new file mode 100644 index 0000000..584e812 --- /dev/null +++ b/progs/dumpdir.pas @@ -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. diff --git a/progs/editor.pas b/progs/editor.pas new file mode 100644 index 0000000..50d6646 --- /dev/null +++ b/progs/editor.pas @@ -0,0 +1,2491 @@ +(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *) +{$H400} +program editor; + +const COMPILERPROG = '#SYSTEM:pcomp.prog'; + ASMPROG = '#SYSTEM:sasm.prog'; + +const MAX_LENGTH = 512; + MAX_LINES = 10000; + MAX_SCREENH = 256; + MAX_KEYWORD = 31; + + MAX_CLIPB_SIZE = 300; + +const ARROW_LEFT = 100000; + ARROW_UP = 100001; + ARROW_RIGHT = 100002; + ARROW_DOWN = 100003; + HOME_KEY = 100004; + END_kEY = 100005; + PG_UP = 100006; + PG_DOWN = 100007; + DELETE_KEY = 100008; + INSERT_KEY = 100009; + HOME_KEY_M = 100010; + END_KEY_M = 100011; + HELP_KEY = 100012; + +const TOPSTAT_BG = 130; + TOPSTAT_FG = 7; + BOTSTAT_BG = 22; + BOTSTAT_FG = 15; + BOTSTAT_BG_W = 124; + BOTSTAT_FG_W = 15; + BOTSTAT_BG_P = 28; + BOTSTAT_FG_P = 15; + BOTSTAT_BG_I = 15; + BOTSTAT_FG_I = 0; + TEXT_FG = 246; + TEXT_BG = 0; + NUM_FG = 219; + IDENT_FG = 145; + KEYWORD_FG =29; + PUNCT_FG = 111; + COMMENT_FG = 66; + STRLIT_FG = 130; + NONTEXT_FG = 57; + +const vMargins = 2; + topMargin = 1; + botMargin = 1; + hScrollDelta = 8; + +type linestr = string[MAX_LENGTH]; + lineref = ^linestr; + +type HiliteCat = (Unknown, WhiteSpc, Keyword, Ident, Number, Punct, Comment, StrLit); + +var lines: array [1..MAX_LINES] of ^linestr; + lineFlags: array [1..MAX_SCREENH] of boolean; + linecount:integer; + screenX:integer; + screenW, screenH:integer; + pageSize:integer; + curX, curY:integer; + topY:integer; + colOffs:integer; + editBuf:^linestr; + editLine:integer; + emptyLine:lineref; + + i:integer; + filename:string; + isNewFile:boolean; + isModified:boolean; + infile:file; + linebuf:linestr; + + con:file; + + curColor:integer; + + botStatMsg:string; + botStatFgColor:integer; + botStatBgColor:integer; + + autoindent: boolean; + highlight: boolean; + + clipboard: array [1..MAX_CLIPB_SIZE] of lineref; + clipboardSz: integer; + keepClips: boolean; + + catColors: array [Unknown..StrLit] of integer = + ( TEXT_FG, 0, KEYWORD_FG, IDENT_FG, NUM_FG, PUNCT_FG, COMMENT_FG, STRLIT_FG ); + + keywords: array [0..MAX_KEYWORD] of string[20] = ( + 'VAR', 'IF', 'THEN', 'ELSE', 'BEGIN', 'END', 'PROCEDURE', 'FUNCTION', + 'WHILE', 'FOR', 'DO', 'IN', 'OF', 'CASE', 'TO', 'REPEAT', 'UNTIL', + 'CHAR', 'INTEGER', 'REAL', 'BOOLEAN', 'ARRAY', 'RECORD', 'STRING', + 'MOD', 'DIV', 'AND', 'OR', 'NOT', + 'TYPE', 'CONST', + 'PROGRAM' + ); + paramPos:integer; + errorLine:integer; + errorMsg:string; + errLineStr:string[12]; + + PArgs:array [0..PArgMax] of string external; + PArgCount:integer external; + +procedure debugOut(s:string;i1,i2:integer); forward; + +procedure showCursor(doShow:boolean); +begin + write(#27,'[?25'); + if doShow then + write('h') + else + write('l'); +end; + + +procedure moveCursor; +begin + GotoXY(screenX - colOffs, curY - topY + topMargin + 1); +end; + +procedure initLineFlags; +var i:integer; +begin + for i := 1 to MAX_SCREENH do + lineFlags[i] := false; +end; + +procedure getScreenSize; +begin + GetTermSize(screenW, screenH); + pageSize := screenH - vMargins; + (* set scrolling region - DECSTBM *) + write(#27,'[2;', 1 + pageSize, 'r'); +end; + +procedure checkScreenSize; +begin + if (screenW < 80) or (screenH <22) then + begin + writeln('Need a minimum screen size of 80x22.'); + halt; + end; +end; + +procedure initScreen; +begin + editBuf := nil; + editLine := -1; + new(emptyLine,12); + emptyLine^ := ''; + + initLineFlags; + TextDefault; + ClrScr; + getScreenSize; + checkScreenSize; + colOffs := 0; + screenX := colOffs + 1; + curX := colOffs + 1; + curY := 1; + topY := 1; + moveCursor; + botStatFgColor := BOTSTAT_FG; + botStatBgColor := BOTSTAT_BG; + botStatMsg := ''; +end; + +procedure resetScreen; +begin + TextDefault; + write(#27,'[r'); (* reset scrolling region *) + ClrScr; +end; + +procedure saveCursor; +begin + write(#27,'7'); (* save cursor position *); +end; + +procedure restoreCursor; +begin + write(#27,'8'); (* restore cursor position *); +end; + + +procedure showTopStatus; +var c:char; +begin + if isModified then + c := '*' + else + c := ' '; + + GotoXY(1,1); + + TextBackground(TOPSTAT_BG); + TextColor(TOPSTAT_FG); + + write('File ', filename, c, ' row:', curY, '/', linecount); + + write(' Indent '); + if autoindent then write('ON') else write('OFF'); + + write(' '); + if keepClips then write('+') else write(' '); + write('Clipb.: '); + if clipboardSz = 0 then write('empty') + else write(clipboardSz, ' lines'); + + ClrEol; + + TextDefault; +end; + +procedure showBotStatus; +begin + GotoXY(1, screenH); + TextColor(botStatFgColor); + TextBackground(botStatBgColor); + write(' ', botStatMsg); + ClrEol; + TextDefault; +end; + +procedure updateStatus; +begin + showCursor(false); + saveCursor; + showTopStatus; + restoreCursor; + showCursor(true); +end; + +function getKey:integer; forward; + +procedure statusMsg(msg:string;warn:boolean;confirm:boolean); +var key:integer; + hinted:boolean; +begin + botStatMsg := msg; + if confirm then + botStatMsg := botStatMsg + ' | [RETURN]'; + + if warn then + begin + botStatFgColor := BOTSTAT_FG_W; + botStatBgColor := BOTSTAT_BG_W; + end + else + begin + botStatFgColor := BOTSTAT_FG; + botStatBgColor := BOTSTAT_BG; + end; + + if length(botStatMsg) + 6 > screenW then + setLength(botStatMsg, screenW - 6); + + showCursor(false); + saveCursor; + showBotStatus; + restoreCursor; + showCursor(true); + if confirm then + begin + hinted := false; + repeat + key := getKey; + if key <> 13 then + begin + write(con, #7); + if not hinted then + begin + hinted := true; + botStatMsg := botStatMsg + '<=='; + saveCursor; + showBotStatus; + restoreCursor; + end; + end; + until key = 13; + statusMsg('', false, false); + end; + +end; + +procedure clearStatus; +begin + statusMsg('', false, false); +end; + +procedure debugOut(s:string;i1,i2:integer); +begin + write(#27,'7'); (* save cursor position *); + GotoXY(40,1); + TextDefault; + write(s); + if i1 >= 0 then write(' ',i1); + if i2 >= 0 then write(' ',i2); + write('.'); + TextColor(curColor); + write(#27,'8'); (* restore cursor position *); +end; + +procedure changeColor(col:integer); +begin + if col <> curColor then + begin + TextColor(col); + curColor := col; + end; +end; + +(* check if a byte is part of a multibyte character, + either leading or continuation byte *) +function isMBChar(b:char):boolean; +begin + (* check if 8th bit is set *) + isMBChar := (ord(b) and $80) <> 0; +end; + +(* check if a byte is a leading byte of a multibyte + character sequence *) +function isMBLead(b:char):boolean; +begin + (* check if upper two bits are 11 *) + isMBLead := (ord(b) and $C0) = $C0; +end; + +(* check if a byte is a continuation byte of a multibyte + character sequence *) +function isMBCont(b:char):boolean; +begin + (* check if upper two bits are 10 *) + isMBCont := (ord(b) and $C0) = $80; +end; + +(* determine the length of a multibyte sequence + from the leading byte *) +function getMBLength(leadingByte:char):integer; +begin + if (ord(leadingByte) and $80) = 0 then + getMBLength := 1 + else + if (ord(leadingByte) and $E0) = $C0 then + getMBLength := 2 + else + if (ord(leadingByte) and $F0) = $E0 then + getMBLength := 3 + else + if (ord(leadingByte) and $F8) = $F0 then + getMBLength := 4 + else (* invalid encoding *) + getMBLength := 1; +end; + +(* ask for input in bottom status line, optionally only digits *) +procedure prompt(msg:string;var strReturn:string;numMode:boolean); +var buf:string; + maxLen:integer; + i,l:integer; + key:integer; + c:char; + done:boolean; + isMB:boolean; + +procedure doBackspace; +begin + if l > 0 then + begin + repeat + isMB := isMBChar(strReturn[l]); + l := l - 1; + until (l < 1 ) or not isMB; + setLength(strReturn, l); + write(con, #8, ' ', #8); + end; +end; + +function isValidChar(ch:char):boolean; +begin + if numMode then + isValidChar := isDigit(ch) + else + isValidChar := (ord(ch) >= 32) and + (ord(ch) <> 127); (* don't want DEL character *) +end; + +begin + maxLen := maxlength(strReturn); + strReturn := ''; + + showCursor(false); + + (* draw line in prompt background color *) + GotoXY(1,ScreenH); + TextColor(BOTSTAT_FG_P); + TextBackground(BOTSTAT_BG_P); + ClrEol; + write(' ', msg, ' '); + + (* draw the input field *) + TextColor(BOTSTAT_FG_I); + TextBackground(BOTSTAT_BG_I); + for i := 1 to maxLen do + write(' '); + + (* place cursor at start of input field *) + TextBackground(BOTSTAT_FG_P); + GotoXY(length(msg) + 4, ScreenH); + + showCursor(true); + + done := false; + repeat + key := getKey; + if key < 255 then (* ignore cursor keys etc *) + begin + c := chr(key); + l := length(strReturn); + + if c = #8 then + doBackspace + else + if isValidChar(c) then + begin + if l < maxLen then + begin + appendchar(strReturn, c); + write(con, c); + end; + end; + + if c = #13 then + done := true; + end; + until done; + + TextDefault; + clearStatus; + moveCursor; +end; + +function getLineRef(l:integer):lineref; +begin + if l = editLine then + if editBuf <> nil then + getLineRef := editBuf + else + getLineRef := lines[l] + else (* duplicate else branch for a litte more speed *) + getLineRef := lines[l]; + + if getLineRef = nil then + getLineRef := emptyLine; +end; + +function getLineLength(l:integer):integer; +begin + getLineLength := length(getLineRef(l)^); +end; + +(* + Determine the number of bytes a character on the screen has. + ASCII characters are one byte long, others are multibyte characters + which can have different lengths. + lineno is the line number in the lines array, + strind is the string index for that line. + If strind points at a continuation byte of a mb sequence, + the result is the remaining number of bytes of the mb sequence. +*) +function charBytes(lineno:integer;strInd:integer):integer; +var lineptr:^linestr; + inMBSeq:boolean; +begin + lineptr := getLineRef(lineno); + charBytes := 1; + if isMBChar(lineptr^[strind]) then + begin + repeat + strind := strind + 1; + if strind <= length(lineptr^) then + begin + inMBSeq := isMBCont(lineptr^[strind]); + if inMBSeq then + charBytes := charBytes + 1; + end + else (* always terminate loop if we are at end of string *) + inMBSeq := false; + until not inMBSeq; + end; +end; + +(* get the number of extra spaces to print + for a tab at screen column x *) +function getTabPadding(x:integer):integer; +begin + getTabPadding := 7 - ((x - 1) mod 8); +end; + + +function findStrInd(lineno:integer;screenX:integer):integer; +var ind,x:integer; + c:char; + expTab:boolean; + lineptr:^linestr; + linelen:integer; +begin + lineptr := getLineRef(lineno); + linelen := length(lineptr^); + ind := 1; x := 1; expTab := false; + while x < screenX do + begin + if ind > linelen then + break; + c := lineptr^[ind]; + if expTab then + begin + x := x + getTabPadding(x); + expTab := false; + end; + if c = #9 then + expTab := true; + + x := x + 1; + ind := ind + charBytes(lineno,ind); + end; + (* debugOut('findStrInd', ind, -1 ); *) + findStrInd := ind; +end; + +(* calculate cursor position from string index of the + specified line *) +function findScreenX(lineno:integer;strind:integer):integer; +var x:integer; + c:char; + expTab:boolean; + lineptr:^linestr; +begin + lineptr := getLineRef(lineno); + x := 0; expTab := false; + for c in lineptr^ do + begin + if expTab then + begin + x := x + getTabPadding(x); + expTab := false; + end; + + strind := strind - 1; + if c = #9 then + expTab := true; + if isMBLead(c) or not isMBCont(c) then + x := x + 1; + if strind = 0 then + break; + end; + (* can return zero if the line is empty *) + findScreenX := x; +end; + +procedure showPage; forward; + +(* Calculate new cursor and line buffer position. + The line buffer position can differ from the + cursor position due to tabs and multibyte characters. + The cursor position may be changed because it is inside + an expanded tab character. + Changes curX and screenX global variables. +*) +procedure reposition; +var x,ind:integer; + c:char; + expTab:boolean; + indPad:integer; + lineptr:^linestr; + linelen:integer; +begin + lineptr := getLineRef(curY); + linelen := length(lineptr^); + + x := 0; ind := 0; expTab := false; indPad := 0; + while x < screenX do + begin + ind := ind + 1; + if ind > linelen then + begin + ind := ind - 1; + break; + end; + + if indPad > 0 then + begin + ind := ind + indPad; + indPad := 0; + end; + + if expTab then + begin + x := x + getTabPadding(x); + expTab := false; + end; + + x := x + 1; + + c := lineptr^[ind]; + if c = #9 then + expTab := true + else + if isMBChar(c) then + indPad := charBytes(curY,ind)-1; + end; + if ind < 1 then ind := 1; + if x < 1 then x := 1; + curX := ind; + screenX := x; + (* debugOut('reposition ', curX, x); *) + if screenX <= colOffs then + begin + colOffs := (screenX div hScrollDelta) * hScrollDelta; + (* debugOut('repos',screenX, colOffs); *) + showPage; + end; + moveCursor; +end; + +procedure hscroll; +begin + if screenX > colOffs + screenW then + begin + (* move viewport so the cursor is visible *) + colOffs := (screenX div hScrollDelta) * hScrollDelta; + (* move viewport again to the end of the line if close + to the right border *) + colOffs := colOffs - ((screenW div hScrollDelta) - 1) * hScrollDelta; + (* debugOut('eolR',screenX, colOffs); *) + showPage; + end + else + if screenX < colOffs then + begin + (* move viewport so the cursor is visible *) + colOffs := (screenX div hScrollDelta) * hScrollDelta + hScrollDelta; + showPage; + end; + + moveCursor; +end; + +procedure gotoCol(col:integer); +var l:lineref; + len:integer; +begin + l := getLineRef(curY); + len := length(l^); + if len = 0 then (* empty line *) + begin + curX := 1; + screenX := 1; + end + else + begin + curX := col; + screenX := findScreenX(curY, curX); + end; + hscroll; +end; + +function isKeyword(var s:string):boolean; +var i:integer; + c:char; + upBuf:string[MAX_LENGTH]; +begin + isKeyword := false; + + if highlight then + begin + upBuf := ''; + for c in s do appendchar(upBuf,upcase(c)); + + + for i := 0 to MAX_KEYWORD do + begin + if keywords[i] = upBuf then + begin + isKeyword := true; + break; + end; + end; + end; +end; + +function isalpha(c:char):boolean; +begin + isalpha := ((ord(c) >= ord('A')) and (ord(c) <= ord('Z'))) or + ((ord(c) >= ord('a')) and (ord(c) <= ord('z'))) or + (c = '_'); +end; + +function ispunct(c:char):boolean; +begin + ispunct := ((ord(c) >= ord('(')) and (ord(c) <= ord('/'))) or + ((ord(c) >= ord(':')) and (ord(c) <= ord('>'))) or + ((ord(c) >= ord('[')) and (ord(c) <= ord('^'))); +end; + +function getCat(c:char):HiliteCat; +begin + if isalpha(c) then + getCat := Keyword + else + if isdigit(c) then + getCat := Number + else + if iswhite(c) then + getCat := WhiteSpc + else + if c = '''' then + getCat := StrLit + else + if c = '{' then + getCat := Comment + else + if ispunct(c) then + getCat := Punct + else + getCat := Unknown; +end; + +procedure markOpenComment(i:integer; flag:boolean); +begin + lineFlags[i] := flag; +end; + +function lineIsComment(i:integer):boolean; +begin + lineIsComment := false; + + i := i - 1; + + if (i>0) and (i<=MAX_SCREENH) then + lineIsComment := lineFlags[i]; +end; + +procedure showLine(i,l:integer); +var tmpl:^linestr; + c:char; + lastChar:char; + cat, prevCat:HiliteCat; + x:integer; + maxX:integer; + lineLen:integer; + pad:integer; + j:integer; + wordBuf:string[MAX_LENGTH]; + buffering:boolean; + inComment:boolean; + inStrLit:boolean; + nextColor:integer; + +procedure showChar(aChar:char); +begin + if (x > colOffs) and (x <= maxX) then + begin + changeColor(nextColor); + conout(aChar); + end; + x := x + 1; +end; + +procedure setNextColor(i:integer); +begin + nextColor := i; +end; + +procedure flushBuf; +var b:char; +begin + if buffering then + begin + if isKeyword(wordBuf) then + setNextColor(KEYWORD_FG) + else + setNextColor(IDENT_FG); + for b in wordBuf do showChar(b); + wordBuf := ''; + buffering := false; + end; +end; + +begin + cat := Unknown; + buffering := false; + inStrLit := false; + wordBuf := ''; + lastChar := #0; + + inComment := lineIsComment(i); + + GotoXY(1,i); + + maxX := colOffs + screenW; + x := 1; + if l <= linecount then + begin + tmpl := getLineRef(l); + if inComment then + setNextColor(COMMENT_FG); + lineLen := length(tmpl^); + for c in tmpl^ do + begin + (* handle tab characters *) + if c = #9 then + begin + flushBuf; + + pad := getTabPadding(x); + for j := 1 to pad do + showChar(' '); + setNextColor(curColor); + c := ' '; + (* c is printed below anyway, so + make it a space *) + end; + + (* handle comments *) + if (c = '*') and (lastChar = '(') then + begin + (* we cheat and don't color the first char + of a "( *"-style comment correctly *) + inComment := true; + setNextColor(COMMENT_FG); + end; + + if inComment then + begin + if c = '}' then + inComment := false + else + if (c = ')') and (lastChar = '*') then + begin + (* we also color the last char of the + comment incorrectly for symmetry *) + inComment := false; + setNextColor(PUNCT_FG); + end; + showChar(c); + end + else + if inStrLit then + begin + if c = '''' then + inStrLit := false; + showChar(c); + end + else + begin + cat := getCat(c); + + if cat = Comment then + inComment := true; + if cat = StrLit then + inStrLit := true; + + if cat = Keyword then + begin + if not buffering then buffering := true; + appendchar(wordBuf, c); + end + else + begin + flushBuf; + setNextColor(catColors[cat]); + showChar(c); + end; + end; + lastChar := c; + end; + flushBuf; + markOpenComment(i, inComment); + end + else + begin + TextColor(NONTEXT_FG); + write('~'); + end; + ClrEol; +end; + +procedure redrawCurLine; +begin + showLine(curY - topY + topMargin + 1, curY); +end; + +procedure showPage; +var i,l:integer; +begin + showCursor(false); + saveCursor; + l := topY; + TextBackground(TEXT_BG); + changeColor(TEXT_FG); + for i := topMargin + 1 to screenH - botMargin do + begin + showLine(i,l); + l := l + 1; + end; + TextDefault; + restoreCursor; + showCursor(true); +end; + +procedure scrollDown; +var i,y:integer; +begin + topY := topY - 1; + lineFlags[topMargin] := false; + for i := screenH downto topMargin + 1 do + lineFlags[i] := lineFlags[i-1]; + moveCursor; + write(#27,'M'); (* RI - scrolls down when at top margin *) + showLine(topMargin + 1, topY); + moveCursor; + + (* if the new line at the top has an open comment, + redraw all following lines until the comment is + closed *) + if lineFlags[topMargin + 1] = true then + begin + y := topY; + for i := topMargin + 2 to 1 + pageSize do + begin + y := y + 1; + showLine(i,y); + if lineFlags[i] = false then + break; + end; + end; +end; + +procedure scrollUp; +var i:integer; +begin + topY := topY + 1; + for i := topMargin to screenH - botMargin do + lineFlags[i] := lineFlags[i+1]; + moveCursor; + write(#27,'D'); (* IND - scrolls up when at bot margin *) + showLine(topMargin + pageSize, topY + pageSize - botMargin); + moveCursor; +end; + +procedure scrollLeft; +begin + colOffs := colOffs + hScrollDelta; + showPage; + moveCursor; +end; + +procedure scrollRight; +begin + colOffs := colOffs - hScrollDelta; + showPage; + moveCursor; +end; + +procedure showScreen; +begin + showTopStatus; + showPage; + moveCursor; +end; + +procedure leaveLine; forward; + +procedure moveUp; +begin + if curY > 1 then + begin + leaveLine; + curY := curY - 1; + if curY < topY then + scrollDown; + reposition; + updateStatus; + end; +end; + +procedure moveDown; +begin + if curY < lineCount then + begin + leaveLine; + curY := curY + 1; + if curY >= (topY + pageSize) then + scrollUp; + reposition; + updateStatus; + end; +end; + +procedure moveLeft; +var newChar:char; +begin + if curX > 1 then + begin + curX := curX - 1; + newChar := getLineRef(curY)^[curX]; + if newChar = #9 then + screenX := findScreenX(curY, curX) + 1 + else + if isMBChar(newChar) then + begin + repeat + curX := curX - 1; + newChar := getLineRef(curY)^[curX]; + until isMBLead(newChar); + end; + screenX := screenX - 1; + + if (screenX <= colOffs) then + scrollRight; + moveCursor; + end; +end; + +procedure moveRight; +var curChar:char; + l:lineref; +begin + l := getLineRef(curY); + if curX <= length(l^) then + begin + curChar := l^[curX]; + if curChar = #9 then + screenX := screenX + getTabPadding(screenX); + curX := curX + 1; + if isMBChar(curChar) then + curX := curX + charBytes(curY, curX); + screenX := screenX + 1; + end; + + if (screenX - colOffs) >= screenW then + scrollLeft; + moveCursor; +end; + +procedure moveBOL; +var oldColOffs:integer; +begin + oldColOffs := colOffs; + curX := 1; + screenX := 1; + colOffs := 0; + if oldColOffs > 0 then + showPage; + moveCursor; +end; + +procedure moveEOL; +var lastChar:char; + l:lineref; + len:integer; +begin + l := getLineRef(curY); + len := length(l^); + if len = 0 then (* empty line *) + begin + curX := 1; + screenX := 1; + end + else + begin + curX := len; + (* we actually move the cursor one char + past the end of the line *) + screenX := findScreenX(curY, curX); + (* if the last char is a tab, we + need to apply the padding *) + lastChar := l^[curX]; + if lastChar = #9 then + screenX := screenX + getTabPadding(screenX); + screenX := screenX + 1; + curX := curX + 1; + end; + { debugOut('moveEOL',curX, screenX); } + if screenX > colOffs + screenW then + begin + (* move viewport so the cursor is visible *) + colOffs := (screenX div hScrollDelta) * hScrollDelta; + (* move viewport again to the end of the line if close + to the right border *) + colOffs := colOffs - ((screenW div hScrollDelta) - 1) * hScrollDelta; + (* debugOut('eolR',screenX, colOffs); *) + showPage; + end; + moveCursor; +end; + +procedure pageUp; +var delta:integer; + oldTopY:integer; + oldY:integer; +begin + oldY := curY; + oldTopY := topY; + delta := pageSize - 1; + + topY := topY - delta; + + (* don't move past first line *) + if topY < 1 then + topY := 1; + + curY := curY - delta; + (* if on first page, just move + cursor to first line *) + if curY < 1 then + curY := 1; + + if oldY <> curY then + begin + leaveLine; + reposition; + if topY <> oldTopY then + showPage; + updateStatus; + moveCursor; + end; +end; + +procedure pageDown; +var delta:integer; + oldY:integer; +begin + oldY := curY; + delta := pageSize - 1; + if (topY + delta) < lineCount then + begin + topY := topY + delta; + curY := curY + delta; + + if curY > lineCount then + curY := lineCount; + showPage; + end + else + curY := lineCount; + + if oldY <> curY then + begin + leaveLine; + reposition; + updateStatus; + moveCursor; + end; +end; + +function getKey:integer; +var c:char; + c1:char; + escSeq:string; + +(* process trailing '~' character for keypad keys *) +function kpKey(k:integer):integer; +var buf:char; +begin + kpKey := k; + read(con,buf); + if not (buf = '~') then + begin + if buf = ';' then + begin + (* xterm sends ESC [1;5H and ESC [1;5F for + Ctrl-Home and Ctrl-End *) + read(con, buf); + if buf = '5' then + begin + read(con, buf); + if buf = 'H' then + kpKey := HOME_KEY_M + else + if buf = 'F' then + kpKey := END_KEY_M; + end; + end + else + if buf = '1' then + begin + (* ESC [11~ for F1 key *) + read(con, buf); + if buf = '~' then + kpKey := HELP_KEY + else + debugOut('inv F-Key', ord(buf), -1); + end + else + debugOut('inv KP', ord(buf), -1); + end; +end; + +(* alt-home and alt-end in putty (?) + are sent like this: + ESC ESC [1~ and + ESC ESC [4~ +*) + +function modKpKey:integer; +var buf:char; +begin + modKpKey := 0; + read(con, buf); + if buf = '[' then + begin + read(con, buf); + if buf = '1' then + modKpKey := HOME_KEY_M + else + if buf = '4' then + modKpKey := END_KEY_M; + read(con, buf); + if buf <> '~' then + modKpKey := 0; + end; +end; + +(* F1 in xterm: ESC O P *) +function fnKey:integer; +var buf:char; +begin + fnKey := 0; + read(con, buf); + if buf = 'P' then + fnKey := HELP_KEY; +end; + +begin (* getKey *) + read(con,c); + if c = #27 then + begin + read(con,c); + if c = '[' then + begin + read(con,c); + case c of + 'D': getKey := ARROW_LEFT; + 'A': getKey := ARROW_UP; + 'C': getKey := ARROW_RIGHT; + 'B': getKey := ARROW_DOWN; + 'H': getKey := HOME_KEY; + 'F': getKey := END_KEY; + '1': getKey := kpKey(HOME_KEY); + '2': getKey := kpKey(INSERT_KEY); + '3': getKey := kpKey(DELETE_KEY); + '4': getKey := kpKey(END_KEY); + '5': getKey := kpKey(PG_UP); + '6': getKey := kpKey(PG_DOWN); + '7'..'9','0': getKey := kpKey(0); + else + getKey := 0; + end; + end + else + if c = 'O' then + getKey := fnKey + else + if c = #27 then + getKey := modKpKey + else + getKey := 0; (* unknown escape sequence *) + end + else + getKey := ord(c); +end; + +function makeNewLine(len:integer):lineref; +var nl:lineref; +begin + if len = 0 then + makeNewLine := nil + else + begin + new(nl, len); + nl^ := ''; + makeNewLine := nl; + end; +end; + +function makeLineCopy(l:lineref):lineref; +var + newl:lineref; +begin + if l = nil then + makeLineCopy := nil + else + if length(l^) = 0 then + makeLineCopy := nil + else + begin + new(newl, length(l^)); + newl^ := l^; + makeLineCopy := newl; + end; +end; + +procedure beginEditBuf; +var srcLine:lineref; +begin + if editBuf = nil then + begin + isModified := true; + new(editBuf); + editLine := curY; + srcLine := lines[editLine]; + if srcLine <> nil then + editBuf^ := srcLine^ + else + editBuf^ := ''; + end; +end; + +procedure commitEditBuf; +var newLine:^linestr; + oldLine:^linestr; +begin + if editBuf <> nil then + begin + (* allocate a new string with the required size *) + newLine := makeNewLine(length(editBuf^)); + (* copy edit buffer contents *) + if length(editBuf^) > 0 then + newLine^ := editBuf^; + (* dispose old line string *) + oldLine := lines[editLine]; + if oldLine <> nil then + dispose(oldLine); + (* set new line string *) + lines[editLine] := newLine; + (* dispose edit buffer *) + dispose(editBuf); + editBuf := nil; + editLine := 0; + end; +end; + +procedure leaveLine; +begin + commitEditBuf; + keepClips := false; + clearStatus; +end; + +procedure insertMBChar(var bytes:string); +var l:integer; + c:char; + insertCount:integer; + x:integer; +begin + (* TODO: check for max line length *) + beginEditBuf; + l := length(editBuf^); + insertCount := length(bytes); + setLength(editBuf^, l + insertCount); + strmoveup(editBuf^, curX, l - curX + 1, insertCount); + x := curX; + for c in bytes do + begin + editBuf^[x] := c; + x := x + 1; + end; + showCursor(false); + showLine(curY - topY + topMargin + 1, curY); + moveRight; + showCursor(true); +end; + +procedure backspaceChar; +var c:char; + l,bcount:integer; + x:integer; + isAtEOL:boolean; + done:boolean; +begin + beginEditBuf; + l := length(editBuf^); + bcount := 0; + x := curX; + isAtEOL := x > l; + + repeat + x := x - 1; + c := editBuf^[x]; + bcount := bcount + 1; + until isMBLead(c) or (not isMBChar(c)); + + (* FIXME: wrong cursor movement if backspacing + at the end of a line consisting of multiple + tabs *) + + (* TODO: refactor moveLeft and backspaceChar + to reuse common code *) + strmovedown(editBuf^, x, l - curX + 1, bcount); + setLength(editBuf^, l - bcount); + + showCursor(false); + + { debugOut('bsCh', curX, bcount); } + + curX := curX - bcount; + + if c = #9 then + begin + (* find new screen position of the cursor *) + screenX := findScreenX(curY, curX); + (* if the cursor was positioned after the + end of the line, and we deleted a tab, + just use moveEOL to deal with the + new cursor position *) + if isAtEOL then + moveEOL; + end + else + screenX := screenX - 1; + + showLine(curY - topY + topMargin + 1, curY); + hscroll; + showCursor(true); +end; + +procedure deleteChar; +var c:char; + l,bcount:integer; +begin + beginEditBuf; + l := length(editBuf^); + c := editBuf^[curX]; + bcount := getMBLength(c); + + strmovedown(editBuf^, curX, l - curX - bcount + 1, bcount); + setLength(editBuf^, l - bcount); + showCursor(false); + showLine(curY - topY + topMargin + 1, curY); + moveCursor; + showCursor(true); +end; + +procedure trimLine(l:lineref); +var len:integer; + done:boolean; +begin + done := false; + repeat + len := length(l^); + if len > 0 then + if l^[len] in [ ' ', #9 ] then + setLength(l^, len - 1) + else + done := true + else + done := true; + until done; +end; + +procedure splitLine; +var newLine:^linestr; + l:integer; + x,y:integer; + c:char; +begin + beginEditBuf; + + l := length(editBuf^) - curX + 1; + + newLine := makeNewLine(l); + if l > 0 then + for x := curX to curX + l - 1 do + appendchar(newLine^, editBuf^[x]); + + setLength(editBuf^, curX - 1); + + commitEditBuf; + + for y := lineCount downto curY + 1 do + lines[y + 1] := lines[y]; + + lines[y + 1] := newLine; + lineCount := lineCount + 1; + + curX := 1; screenX := 1; colOffs := 0; + moveDown; + showPage; +end; + +procedure joinUpLine; +var c:char; + nextLine:lineref; + i:integer; +begin + beginEditBuf; + if curY < lineCount then + begin + nextLine := lines[curY + 1]; + if nextLine <> nil then + begin + for c in nextLine^ do + appendchar(editBuf^, c); + dispose(nextLine); + end; + commitEditBuf; + for i := curY + 1 to linecount - 1 do + lines[i] := lines[i+1]; + + linecount := linecount - 1; + end; +end; + +procedure backspaceKey; +var predLine:integer; + newX:integer; +begin + if curX > 1 then + backspaceChar + else + if curY > 1 then + begin + leaveLine; + curY := curY - 1; + moveEOL; + joinUpLine; + showPage; + end; +end; + +procedure deleteKey; +var nextLine:integer; + len:integer; + newX:integer; +begin + len := getLineLength(curY); + + if curX <= len then + deleteChar + else + if curY < lineCount then + begin + leaveLine; + joinUpLine; + showPage; + end; +end; + +procedure tab; +var buf:string[1]; +begin + buf := #9; + insertMBChar(buf); +end; + +procedure enter; +var lastLine:lineref; + c:char; + i:integer; + buf:string[4]; +begin + splitLine; + if autoindent and (curY > 1) then + begin + lastLine := getLineRef(curY - 1); + if length(lastLine^) > 0 then + begin + if length(lastLine^) > 3 then + begin + if copy(lastLine^,1,4) = 'var ' then + begin + buf := ' '; + insertMBChar(buf); + moveEOL; + end; + end; + + for c in lastLine^ do + begin + if (c <> #32) and (c <> #9 ) then + break; + buf := c; + insertMBChar(buf); + end; + end; + trimLine(lastLine); + end; + clearStatus; +end; + +procedure writeFile(var success:boolean); forward; + +procedure save; +var success:boolean; +begin + writeFile(success); + if success then + begin + isNewFile := false; + isModified := false; + updateStatus; + end; +end; + +procedure saveNQuit(var success:boolean); +begin + writeFile(success); +end; + +procedure undo; +begin + if editLine > 0 then + begin + dispose(editBuf); + editLine := 0; + editBuf := nil; + showCursor(false); + redrawCurLine; + reposition; + showCursor(true); + end; +end; + +procedure quit(var success:boolean); +var key:integer; +begin + if isModified then + begin + statusMsg('File was modified, press [RETURN] to discard changes and quit...', true, false); + key := getKey; + success := key = 13; + if not success then + clearStatus; + end + else + success := true; +end; + +procedure gotoLine(l:integer); +begin + if l < 1 then + l := 1 + else + if l > lineCount then + l := lineCount; + + topY := l - (screenH div 2); + if topY < 1 then + topY := 1; + curY := l; + curX := 1; + showPage; + reposition; + updateStatus; +end; + +procedure cleanup; +begin + close(con); + resetScreen; +end; + +function endsWith(var s:string; suffix:string):boolean; +var len, lenSuffix:integer; +begin + endsWith := false; + + len := length(s); + lenSuffix := length(suffix); + if len >= length(suffix) then + endsWith := suffix = copy(s, len - lenSuffix + 1, lenSuffix); +end; + +function isPasFile(var filename:string):boolean; +begin + isPasFile := endsWith(filename, '.pas'); +end; + +function isAsmFile(var filename:string):boolean; +begin + isAsmFile := endsWith(filename, '.s'); +end; + +procedure buildNRun(doAsm:boolean;doRun:boolean); +var error:integer; + success:boolean; + args:PArgVec; + argPos:integer; + prg:string; +begin + success := true; + if isModified then + save; + if success then + begin + if isAsmFile(filename) then + prg := ASMPROG + else + prg := COMPILERPROG; + + cleanup; + writeln('Running ', prg ,'...'); + (* ask the shell to start the editor + again after the last program exits *) + SetShellCmd('WE', curY); + + (* ask the compiler/assembler to call + the editor on error *) + args[0] := '-e'; + argPos := 1; + if not doAsm then + begin + (* tell the compiler to only + create the assembly file *) + args[argPos] := '-S'; + argPos := argPos + 1; + end; + if doRun then + begin + (* ask the compiler/assembler to run the program *) + args[argPos] := '-R'; + argPos := argPos + 1; + end; + args[argPos] := filename; + PExec(prg, args, argPos + 1, error); + writeln('PExec failed, error ', error); + end; +end; + +procedure switchOptions; +begin + autoindent := not autoindent; + updateStatus; + + (* toggle autoindent, + toggle case-insensitve search?*) +end; + +procedure askLine; +var buf:string[12]; + l,p:integer; +begin + prompt('Go to line:', buf, true); + val(buf, l, p); + if p = 0 then + gotoLine(l); +end; + +procedure clearClipboard; +var ci:integer; +begin + for ci := 1 to clipboardSz do + begin + if clipboard[ci] <> nil then + begin + dispose(clipboard[ci]); + clipboard[ci] := nil; + end; + end; + + clipboardSz := 0; +end; + +procedure lineToClipboard(var success:boolean); +var l:lineref; + cur:lineref; +begin + if not keepClips then + clearClipboard; + + if clipboardSz < MAX_CLIPB_SIZE then + begin + clipboardSz := clipboardSz + 1; + + cur := getLineRef(curY); + l := makeNewLine(length(cur^)); + if l <> nil then + l^ := cur^; + clipboard[clipboardSz] := l; + success := true; + end + else + begin + success := false; + statusMsg('Clipboard full', true, false); + end; +end; + +procedure copyLine; +var success:boolean; +begin + lineToClipboard(success); + if success then + begin + moveBOL; + moveDown; + keepClips := true; + updateStatus; + end; +end; + +procedure deleteLine; +var l:lineref; + success:boolean; +begin + commitEditBuf; + lineToClipboard(success); + keepClips := true; + if lines[curY] <> nil then + begin + dispose(lines[curY]); + lines[curY] := nil; + end; + joinUpLine; + if curY > lineCount then + curY := lineCount; + if lineCount = 0 then + begin + curY := 1; + linecount := 1; + lines[1] := makeNewLine(0); + end; + + moveBOL; + showPage; + updateStatus; +end; + +procedure insertClipboard; +var i:integer; + ci:integer; +begin + if lineCount + clipboardSz <= MAX_LINES then + begin + if clipboardSz > 0 then + begin + (* move rest of the lines away *) + for i := lineCount downto curY do + lines[i + clipboardSz] := lines[i]; + + ci := 1; + for i := curY to curY + clipboardSz - 1 do + begin + lines[i] := makeLineCopy(clipboard[ci]); + ci := ci + 1; + end; + + lineCount := lineCount + clipboardSz; + + isModified := true; + end + end + else + statusMsg('Maximum number of lines reached.', true, false); +end; + +procedure paste; +begin + commitEditBuf; + insertClipboard; + showPage; + keepClips := false; + updateStatus; +end; + +procedure enableCollect; +begin + keepClips := true; + updateStatus; +end; + +procedure findReplace(ignoreCase:boolean); +var buf:string[40]; + p:integer; + i:integer; + l:lineref; + done:boolean; + startPos:integer; + replace:boolean; + reverse:boolean; + wrapped:boolean; + savedX,savedY:integer; + replaceBuf:string[40]; + linesSearched:integer; + +procedure doReplace; +var delta:integer; + s,d:integer; + tailLength:integer; +begin + if replace = false then + begin + replace := true; + prompt('Replace with:', replaceBuf, false); + end; + if p > 0 then + begin + beginEditBuf; + delta := length(replaceBuf) - length(buf); + + if delta > 0 then + begin + tailLength := length(editBuf^) - p + 1 - length(buf); + setLength(editBuf^, length(editBuf^) + delta); + strmoveup(editBuf^, p + length(buf), + tailLength, delta); + end + else + if delta < 0 then + begin + strmovedown(editBuf^, p, + length(editBuf^) - p + delta + 1, -delta); + setLength(editBuf^, length(editBuf^) + delta); + end; + + (* TODO: check for max line length *) + + s := 1; + for d := p to p + length(replaceBuf) - 1 do + begin + editBuf^[d] := replaceBuf[s]; + s := s + 1; + end; + (* commitEditBuf; *) + showCursor(false); + TextDefault; + redrawCurLine; + showCursor(true); + + moveCursor; + end; +end; + +procedure findPrompt; +var key:integer; + ch:char; + valid:boolean; +begin + showCursor(false); + GotoXY(1,ScreenH); + TextColor(BOTSTAT_FG_P); + TextBackground(BOTSTAT_BG_P); + ClrEol; + write(' Find: next, [RET] finish, [B]ackwards, [R]eplace ('); + if ignoreCase then write('Ign.') + else write('Match '); + write('Case'); + if wrapped then write(' WRAP', #7); + write(')>'); + + moveCursor; + + showCursor(true); + + repeat + key := getKey; + valid := true; + case key of + 13: done := true; (* CR *) + 32: reverse := false; (* Space *) + 84,114: doReplace; (* R, r *) + 66,98: reverse := true; (* B, b *) + else + begin + valid := false; + write(con, #7); (* BEL *) + end; + end; + until valid; + TextDefault; +end; + +(* modified from stdlib.pas *) +function posIgnCase(substr:string;var s:string;startPos:integer):integer; +var substrlen:integer; + slen:integer; + searchpos:integer; + subchar:char; + subpos:integer; + found:boolean; + c1,c2:char; + delta:integer; +begin + found := false; + substrlen := length(substr); + slen := length(s); + + subpos := 1; + + if reverse then + begin + searchpos := startPos - 1; + delta := -1; + end + else + begin + searchpos := startPos; + delta := 1; + end; + + if(substrlen > 0) and (slen>0) and ((startPos + substrlen - 1) <= slen) then + begin + while not found and (searchpos + subpos - 1 <= slen) and (searchpos > 0) do + begin + (* compare character by character *) + c1 := substr[subpos]; + c2 := s[searchpos + subpos - 1]; + if ignoreCase then + begin + c1 := upcase(c1); + c2 := upcase(c2); + end; + + if c1 <> c2 then + begin + (* If a character does not match, reset the + character index of the substring + and go to next character *) + searchpos := searchpos + delta; + subpos := 1; + end + else + begin + (* character does match *) + if subpos = 1 then + (* remember start of this search attempt *) + posIgnCase := searchpos; + + (* if this was the last character of the substring, + we are successful *) + if subpos = substrlen then + found := true + else + (* else go to next characters *) + subpos := subpos + 1; + end; + end; + end; + + if not found then + posIgnCase := 0; +end; + +begin (* findReplace *) + replace := false; + reverse := false; + wrapped := false; + + savedX := curX; + savedY := curY; + linesSearched := 0; + startPos := curX; + prompt('Find text:', buf, false); + + if length(buf) > 0 then + begin + leaveLine; + i := curY; + done := false; + repeat + l := getLineRef(i); + p := posIgnCase(buf,l^,startPos); + if p > 0 then + begin + linesSearched := 0; + gotoLine(i); + gotoCol(p); + savedX := curX; + savedY := curY; + findPrompt; + wrapped := false; + if reverse then + startPos := p - 1 + else + startPos := p + 1; + end + else + begin + (* move to next line *) + leaveLine; + linesSearched := linesSearched + 1; + if reverse then + begin + i := i - 1; + if i < 1 then + begin + i := linecount; + wrapped := true; + end; + startPos := getLineLength(i) - length(buf) + 1; + end + else + begin + startPos := 1; + i := i + 1; + if i > linecount then + begin + i := 1; + wrapped := true; + end; + end; + + if linesSearched > lineCount then + begin + statusMsg('Nothing found.', false, true); + done := true; + end; + end; + until done; + end; + + gotoLine(savedY); + curX := savedX; + reposition; + statusMsg('', false, false); +end; + +procedure writeClip; +var newFilename:string[50]; + clipfile:file; + ci:integer; +begin + prompt('Write clipboard to file:', newFilename, false); + if length(newFilename) > 0 then + begin + open(clipfile, newfilename, ModeCreate); + if IOResult(clipfile) = IONoError then + begin + for ci := 1 to clipboardSz do + writeln(clipfile, clipboard[ci]^); + close(clipfile); + statusMsg('Write successful.', false, false); + end + else + statusMsg('Write clipboard failed - ' + + ErrorStr(IOResult(clipfile)), true, true); + end; +end; + +procedure readClip; +var fname:string[50]; + clipfile:file; + ci:integer; + linebuf:string[255]; + l:lineref; + error:boolean; +begin + prompt('Read clipboard from file:', fname, false); + + if length(fname) = 0 then exit; + + clearClipboard; + ci := 0; + open(clipfile, fname, ModeReadonly); + if IOResult(clipfile) <> IONoError then + statusMsg('Error reading file - ' + + ErrorStr(IOResult(clipfile)), true, true) + else + begin + error := false; + while not eof(clipfile) or error do + begin + if ci >= MAX_CLIPB_SIZE then + begin + statusMsg('Clipboard full', true, false); + error := true; + end + else + begin + readln(clipfile, linebuf); + ci := ci + 1; + l := makeNewLine(length(linebuf)); + if l <> nil then + l^ := linebuf; + clipboard[ci] := l; + end; + end; + clipboardSz := ci; + close(clipfile); + if not error then + statusMsg('File successfully read to clipboard.', false, false); + end; + updateStatus; +end; + +procedure saveNewFile(var success:boolean); +var newFilename:string[50]; + oldName:string; + oldNewFlag:boolean; +begin + prompt('New filename:', newFilename, false); + if length(newFilename) > 0 then + begin + oldName := filename; + oldNewFlag := isNewFile; + + filename := newFilename; + isNewFile := true; + writeFile(success); + if not success then + begin + filename := oldName; + isNewFile := oldNewFlag; + end; + end + else + success := false; +end; + +procedure redraw; +begin + getScreenSize; + showScreen; + gotoLine(curY); +end; + +procedure helpScreen; +var i:integer; +begin + showCursor(false); + GotoXY(1,3); + TextColor(15); + (* TextBackground(24); *) + TextBackground(23); + TextColor(15); + write(' Keyboard Commands (^ = Control + other key)'); + ClrEol; + TextBackground(22); + TextColor(15); + for i := 1 to 18 do + begin + writeln; + ClrEol; + end; + + GotoXY(1,5); + writeln('Saving/Exiting Editing/Clipboard'); + writeln('^Q save and Quit ^Y delete line (and copy to clipb.)'); + writeln('^W save ^C Copy line'); + writeln('^A save As new and quit ^V paste clipboard contents'); + writeln('^X eXit without saving ^R Read clipboard from file'); + writeln(' ^O write clipboard to file'); + writeln(' ^K Keep previous clipboard on ^Y/^C'); + writeln('Compiling ^Z undo changes to current line'); + writeln('^B Build (compile, assemble)'); + writeln('^N build and ruN Others'); + writeln('^P comPile only ^T Toggle audoindent'); + writeln(' ^L redraw screen'); + writeln(' ^F Find/replace'); + writeln('Moving around ^E find/replace (match casE)'); + writeln('^G Goto line'); + writeln('Move with cursor keys, Home, End, PgUp, PgDown'); + writeln; + GotoXY(ScreenW,ScreenH); + statusMsg('Help Screen', false, true); + showCursor(true); + redraw; +end; + +procedure edit; +var key:integer; + c:char; + buf:string[4]; + i:integer; + done:boolean; +begin + done := false; + repeat + key := getKey; + case key of + ARROW_LEFT:moveLeft; + ARROW_UP:moveUp; + ARROW_RIGHT:moveRight; + ARROW_DOWN:moveDown; + PG_UP:pageUp; + PG_DOWN:pageDown; + HOME_KEY:moveBOL; + END_KEY:moveEOL; + INSERT_KEY:; + DELETE_KEY:deleteKey; + HOME_KEY_M:gotoLine(1); + END_KEY_M:gotoLine(lineCount); + HELP_KEY:helpScreen; + 8: backspaceKey; + 127: backspaceKey; + 9: tab; + 13: enter; + 2: buildNRun(true,false); (* ^B *) + 14: buildNRun(true, true); (* ^N *) + 16: buildNRun(false, false); (* ^P *) + 23: save; (* ^W *) + 17: saveNQuit(done); (* ^Q *) + 24: quit(done); (* ^X *) + 15: writeClip; (* ^O *) + 1: saveNewFile(done); (* ^A *) + 26: undo; (* ^Z *) + 7: askLine; (* ^G *) + 18: readClip; (* ^R *) + 20: switchOptions; (* ^T *) + 6: findReplace(true); (* ^F *) + 5: findReplace(false); (* ^E *) + 25: deleteLine; (* ^Y *) + 3: copyLine; (* ^C *) + 22: paste; (* ^V *) + 11: enableCollect; (* ^K *) + 12: redraw; (* ^L *) + else + if key > 31 then + begin + buf := ''; + c := chr(key); + appendchar(buf,c); + for i := 2 to getMBLength(c) do + begin + c := chr(getKey); + appendchar(buf, c); + end; + insertMBChar(buf); + end + else + statusMsg(' Press F1 for help.', false, false); + end; + until done; (* ^X *) +end; + +procedure readFile(var f:file); +var + tmpline:^linestr; +begin + write('Reading file ', filename, '...'); + linecount := 0; + while not eof(f) do + begin + linecount := linecount + 1; + readln(f, linebuf); + if length(linebuf) = 0 then + tmpline := nil + else + begin + new(tmpline, length(linebuf)); + tmpline^ := linebuf; + end; + lines[linecount] := tmpline; + if (linecount and 511) = 0 then + write('.'); + end; + isNewFile := false; + isModified := false; +end; + +procedure newFile; +begin + linecount := 1; + lines[1] := makeNewLine(0); + isNewFile := true; + isModified := false; +end; + +procedure writeFile(var success:boolean); +var mode:filemode; + outfile:file; + i:integer; + l:lineref; +begin + if isNewFile then + mode := ModeCreate + else + mode := ModeOverwrite; + + open(outfile, filename, mode); + + if IOResult(outfile) <> IONoError then + begin + statusMsg('Write failed - ' + ErrorStr(IOResult(outfile)), true, true); + success := false; + end + else + begin + commitEditBuf; + statusMsg('Writing file...', false, false); + success := true; + for i := 1 to linecount do + begin + l := lines[i]; + if l <> nil then + writeln(outfile, l^) + else + writeln(outfile); + if IOResult(outfile) <> IONoError then + begin + statusMsg('Error writing file: ' + + ErrorStr(IOResult(outfile)), true, true); + success := false; + break; + end; + end; + close(outfile); + if success then + begin + statusMsg('Write successful.', false, false); + isModified := false; + end; + end; +end; + +begin + errorLine := 0; + paramPos := 1; + filename := ''; + autoindent := true; + keepClips := false; + + while paramPos <= ParamCount do + begin + if paramStr(paramPos) = '-l' then + begin + paramPos := paramPos + 1; + errLineStr := ParamStr(paramPos); + val(errLineStr, errorLine, i); + end + else + if paramStr(paramPos) = '-E' then + begin + paramPos := paramPos + 1; + errorMsg := ParamStr(paramPos); + end + else + filename := ParamStr(paramPos); + paramPos := paramPos + 1; + end; + + if length(filename) = 0 then + begin + write('Filename: '); + readln(filename); + end; + + highlight := isPasFile(filename); + + open(infile, filename, ModeReadonly); + if IOResult(infile) = IOFileNotFound then + newFile + else + if IOResult(infile) <> IONoError then + begin + writeln('Error opening file ', filename, ': ', + ErrorStr(IOResult(infile))); + halt; + end + else + begin + readFile(infile); + close(infile); + end; + + initScreen; + showScreen; + + if isNewFile then + statusMsg('New file. Press F1 for help.', false, false) + else + statusMsg('Successfully read file. Press F1 for help', false, false); + + open(con, '%RAW', ModeOverwrite); + + if errorLine > 0 then + begin + gotoLine(errorLine); + if length(errorMsg) > 0 then + statusMsg('E: ' + errorMsg + ' at line ' + errLineStr, true, true); + end; + + edit; + + (* hack to remember the current line + if we open the same file again *) + SetShellCmd('', curY); + + cleanup; +end. diff --git a/progs/partmgr.pas b/progs/partmgr.pas new file mode 100644 index 0000000..b929385 --- /dev/null +++ b/progs/partmgr.pas @@ -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 := ''; +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. diff --git a/progs/reclaim.pas b/progs/reclaim.pas new file mode 100644 index 0000000..c61cc53 --- /dev/null +++ b/progs/reclaim.pas @@ -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. diff --git a/progs/shell.pas b/progs/shell.pas new file mode 100644 index 0000000..610dcfe --- /dev/null +++ b/progs/shell.pas @@ -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. diff --git a/progs/xfer.pas b/progs/xfer.pas new file mode 100644 index 0000000..7a4a389 --- /dev/null +++ b/progs/xfer.pas @@ -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. diff --git a/rtl/arty-a7/Arty-A7-35-Master.xdc b/rtl/arty-a7/Arty-A7-35-Master.xdc new file mode 100644 index 0000000..c618478 --- /dev/null +++ b/rtl/arty-a7/Arty-A7-35-Master.xdc @@ -0,0 +1,218 @@ +## This file is a general .xdc for the Arty A7-35 Rev. D +## To use it in a project: +## - uncomment the lines corresponding to used pins +## - rename the used ports (in each line, after get_ports) according to the top level signal names in the project + +## Clock signal +set_property -dict {PACKAGE_PIN E3 IOSTANDARD LVCMOS33} [get_ports clk] +create_clock -period 10.000 -name sys_clk_pin -waveform {0.000 5.000} -add [get_ports clk] + +## Switches +set_property -dict {PACKAGE_PIN A8 IOSTANDARD LVCMOS33} [get_ports sw0] +set_property -dict {PACKAGE_PIN C11 IOSTANDARD LVCMOS33} [get_ports sw1] +#set_property -dict { PACKAGE_PIN C10 IOSTANDARD LVCMOS33 } [get_ports { sw[2] }]; #IO_L13N_T2_MRCC_16 Sch=sw[2] +#set_property -dict { PACKAGE_PIN A10 IOSTANDARD LVCMOS33 } [get_ports { sw[3] }]; #IO_L14P_T2_SRCC_16 Sch=sw[3] + +## RGB LEDs +#set_property -dict { PACKAGE_PIN E1 IOSTANDARD LVCMOS33 } [get_ports { led0_b }]; #IO_L18N_T2_35 Sch=led0_b +#set_property -dict { PACKAGE_PIN F6 IOSTANDARD LVCMOS33 } [get_ports { led0_g }]; #IO_L19N_T3_VREF_35 Sch=led0_g +#set_property -dict { PACKAGE_PIN G6 IOSTANDARD LVCMOS33 } [get_ports { led0_r }]; #IO_L19P_T3_35 Sch=led0_r +#set_property -dict { PACKAGE_PIN G4 IOSTANDARD LVCMOS33 } [get_ports { led1_b }]; #IO_L20P_T3_35 Sch=led1_b +#set_property -dict { PACKAGE_PIN J4 IOSTANDARD LVCMOS33 } [get_ports { led1_g }]; #IO_L21P_T3_DQS_35 Sch=led1_g +#set_property -dict { PACKAGE_PIN G3 IOSTANDARD LVCMOS33 } [get_ports { led1_r }]; #IO_L20N_T3_35 Sch=led1_r +#set_property -dict { PACKAGE_PIN H4 IOSTANDARD LVCMOS33 } [get_ports { led2_b }]; #IO_L21N_T3_DQS_35 Sch=led2_b +#set_property -dict { PACKAGE_PIN J2 IOSTANDARD LVCMOS33 } [get_ports { led2_g }]; #IO_L22N_T3_35 Sch=led2_g +#set_property -dict { PACKAGE_PIN J3 IOSTANDARD LVCMOS33 } [get_ports { led2_r }]; #IO_L22P_T3_35 Sch=led2_r +#set_property -dict { PACKAGE_PIN K2 IOSTANDARD LVCMOS33 } [get_ports { led3_b }]; #IO_L23P_T3_35 Sch=led3_b +#set_property -dict { PACKAGE_PIN H6 IOSTANDARD LVCMOS33 } [get_ports { led3_g }]; #IO_L24P_T3_35 Sch=led3_g +#set_property -dict { PACKAGE_PIN K1 IOSTANDARD LVCMOS33 } [get_ports { led3_r }]; #IO_L23N_T3_35 Sch=led3_r + +## LEDs +set_property -dict {PACKAGE_PIN H5 IOSTANDARD LVCMOS33} [get_ports led0] +set_property -dict {PACKAGE_PIN J5 IOSTANDARD LVCMOS33} [get_ports led1] +set_property -dict {PACKAGE_PIN T9 IOSTANDARD LVCMOS33} [get_ports led2] +set_property -dict {PACKAGE_PIN T10 IOSTANDARD LVCMOS33} [get_ports led3] + +## Buttons +set_property -dict {PACKAGE_PIN D9 IOSTANDARD LVCMOS33} [get_ports btn0] +#set_property -dict { PACKAGE_PIN C9 IOSTANDARD LVCMOS33 } [get_ports { btn1 }]; #IO_L11P_T1_SRCC_16 Sch=btn[1] +#set_property -dict { PACKAGE_PIN B9 IOSTANDARD LVCMOS33 } [get_ports { btn[2] }]; #IO_L11N_T1_SRCC_16 Sch=btn[2] +#set_property -dict { PACKAGE_PIN B8 IOSTANDARD LVCMOS33 } [get_ports { btn[3] }]; #IO_L12P_T1_MRCC_16 Sch=btn[3] + +## Pmod Header JA +set_property -dict {PACKAGE_PIN G13 IOSTANDARD LVCMOS33} [get_ports sd_cs_n] +set_property -dict {PACKAGE_PIN B11 IOSTANDARD LVCMOS33} [get_ports sd_mosi] +set_property -dict {PACKAGE_PIN A11 IOSTANDARD LVCMOS33} [get_ports sd_miso] +set_property -dict {PACKAGE_PIN D12 IOSTANDARD LVCMOS33} [get_ports sd_sck] +#set_property -dict { PACKAGE_PIN D13 IOSTANDARD LVCMOS33 } [get_ports { sd_dat1 }]; #IO_L6N_T0_VREF_15 Sch=ja[7] +#set_property -dict { PACKAGE_PIN B18 IOSTANDARD LVCMOS33 } [get_ports { sd_dat2 }]; #IO_L10P_T1_AD11P_15 Sch=ja[8] +set_property -dict {PACKAGE_PIN A18 IOSTANDARD LVCMOS33} [get_ports sd_cd] +#set_property -dict { PACKAGE_PIN K16 IOSTANDARD LVCMOS33 } [get_ports { sd_nc }]; #IO_25_15 Sch=ja[10] + +###Pmod Header JB +set_property -dict {PACKAGE_PIN E15 IOSTANDARD LVCMOS33} [get_ports {VGA_R[0]}] +set_property -dict {PACKAGE_PIN E16 IOSTANDARD LVCMOS33} [get_ports {VGA_R[1]}] +set_property -dict {PACKAGE_PIN D15 IOSTANDARD LVCMOS33} [get_ports {VGA_R[2]}] +set_property -dict {PACKAGE_PIN C15 IOSTANDARD LVCMOS33} [get_ports {VGA_R[3]}] +set_property -dict {PACKAGE_PIN J17 IOSTANDARD LVCMOS33} [get_ports {VGA_B[0]}] +set_property -dict {PACKAGE_PIN J18 IOSTANDARD LVCMOS33} [get_ports {VGA_B[1]}] +set_property -dict {PACKAGE_PIN K15 IOSTANDARD LVCMOS33} [get_ports {VGA_B[2]}] +set_property -dict {PACKAGE_PIN J15 IOSTANDARD LVCMOS33} [get_ports {VGA_B[3]}] + +###Pmod Header JC +set_property -dict {PACKAGE_PIN U12 IOSTANDARD LVCMOS33} [get_ports {VGA_G[0]}] +set_property -dict {PACKAGE_PIN V12 IOSTANDARD LVCMOS33} [get_ports {VGA_G[1]}] +set_property -dict {PACKAGE_PIN V10 IOSTANDARD LVCMOS33} [get_ports {VGA_G[2]}] +set_property -dict {PACKAGE_PIN V11 IOSTANDARD LVCMOS33} [get_ports {VGA_G[3]}] +set_property -dict {PACKAGE_PIN U14 IOSTANDARD LVCMOS33} [get_ports VGA_HS_O] +set_property -dict {PACKAGE_PIN V14 IOSTANDARD LVCMOS33} [get_ports VGA_VS_O] +#set_property -dict { PACKAGE_PIN T13 IOSTANDARD LVCMOS33 } [get_ports { jc[6] }]; #IO_L23P_T3_A03_D19_14 Sch=jc_p[4] +#set_property -dict { PACKAGE_PIN U13 IOSTANDARD LVCMOS33 } [get_ports { jc[7] }]; #IO_L23N_T3_A02_D18_14 Sch=jc_n[4] + +## Pmod Header JD +#set_property -dict { PACKAGE_PIN D4 IOSTANDARD LVCMOS33 } [get_ports { jd[0] }]; #IO_L11N_T1_SRCC_35 Sch=jd[1] +#set_property -dict { PACKAGE_PIN D3 IOSTANDARD LVCMOS33 } [get_ports { jd[1] }]; #IO_L12N_T1_MRCC_35 Sch=jd[2] +#set_property -dict { PACKAGE_PIN F4 IOSTANDARD LVCMOS33 } [get_ports { jd[2] }]; #IO_L13P_T2_MRCC_35 Sch=jd[3] +#set_property -dict { PACKAGE_PIN F3 IOSTANDARD LVCMOS33 } [get_ports { jd[3] }]; #IO_L13N_T2_MRCC_35 Sch=jd[4] +#set_property -dict { PACKAGE_PIN E2 IOSTANDARD LVCMOS33 } [get_ports { jd[4] }]; #IO_L14P_T2_SRCC_35 Sch=jd[7] +#set_property -dict { PACKAGE_PIN D2 IOSTANDARD LVCMOS33 } [get_ports { jd[5] }]; #IO_L14N_T2_SRCC_35 Sch=jd[8] +#set_property -dict { PACKAGE_PIN H2 IOSTANDARD LVCMOS33 } [get_ports { jd[6] }]; #IO_L15P_T2_DQS_35 Sch=jd[9] +#set_property -dict { PACKAGE_PIN G2 IOSTANDARD LVCMOS33 } [get_ports { jd[7] }]; #IO_L15N_T2_DQS_35 Sch=jd[10] + +## USB-UART Interface +set_property -dict {PACKAGE_PIN D10 IOSTANDARD LVCMOS33} [get_ports uart_rxd_out] +set_property -dict {PACKAGE_PIN A9 IOSTANDARD LVCMOS33} [get_ports uart_txd_in] + +## ChipKit Outer Digital Header +#set_property -dict { PACKAGE_PIN V15 IOSTANDARD LVCMOS33 } [get_ports { ck_io0 }]; #IO_L16P_T2_CSI_B_14 Sch=ck_io[0] +#set_property -dict { PACKAGE_PIN U16 IOSTANDARD LVCMOS33 } [get_ports { ck_io1 }]; #IO_L18P_T2_A12_D28_14 Sch=ck_io[1] +#set_property -dict { PACKAGE_PIN P14 IOSTANDARD LVCMOS33 } [get_ports { ck_io2 }]; #IO_L8N_T1_D12_14 Sch=ck_io[2] +#set_property -dict { PACKAGE_PIN T11 IOSTANDARD LVCMOS33 } [get_ports { ck_io3 }]; #IO_L19P_T3_A10_D26_14 Sch=ck_io[3] +#set_property -dict { PACKAGE_PIN R12 IOSTANDARD LVCMOS33 } [get_ports { ck_io4 }]; #IO_L5P_T0_D06_14 Sch=ck_io[4] +#set_property -dict { PACKAGE_PIN T14 IOSTANDARD LVCMOS33 } [get_ports { ck_io5 }]; #IO_L14P_T2_SRCC_14 Sch=ck_io[5] +#set_property -dict { PACKAGE_PIN T15 IOSTANDARD LVCMOS33 } [get_ports { ck_io6 }]; #IO_L14N_T2_SRCC_14 Sch=ck_io[6] +#set_property -dict { PACKAGE_PIN T16 IOSTANDARD LVCMOS33 } [get_ports { ck_io7 }]; #IO_L15N_T2_DQS_DOUT_CSO_B_14 Sch=ck_io[7] +#set_property -dict { PACKAGE_PIN N15 IOSTANDARD LVCMOS33 } [get_ports { ck_io8 }]; #IO_L11P_T1_SRCC_14 Sch=ck_io[8] +#set_property -dict { PACKAGE_PIN M16 IOSTANDARD LVCMOS33 } [get_ports { ck_io9 }]; #IO_L10P_T1_D14_14 Sch=ck_io[9] +#set_property -dict { PACKAGE_PIN V17 IOSTANDARD LVCMOS33 } [get_ports { ck_io10 }]; #IO_L18N_T2_A11_D27_14 Sch=ck_io[10] +#set_property -dict { PACKAGE_PIN U18 IOSTANDARD LVCMOS33 } [get_ports { ck_io11 }]; #IO_L17N_T2_A13_D29_14 Sch=ck_io[11] +#set_property -dict { PACKAGE_PIN R17 IOSTANDARD LVCMOS33 } [get_ports { ck_io12 }]; #IO_L12N_T1_MRCC_14 Sch=ck_io[12] +#set_property -dict { PACKAGE_PIN P17 IOSTANDARD LVCMOS33 } [get_ports { ck_io13 }]; #IO_L12P_T1_MRCC_14 Sch=ck_io[13] + +## ChipKit Inner Digital Header +#set_property -dict { PACKAGE_PIN U11 IOSTANDARD LVCMOS33 } [get_ports { ck_io26 }]; #IO_L19N_T3_A09_D25_VREF_14 Sch=ck_io[26] +#set_property -dict { PACKAGE_PIN V16 IOSTANDARD LVCMOS33 } [get_ports { ck_io27 }]; #IO_L16N_T2_A15_D31_14 Sch=ck_io[27] +#set_property -dict { PACKAGE_PIN M13 IOSTANDARD LVCMOS33 } [get_ports { ck_io28 }]; #IO_L6N_T0_D08_VREF_14 Sch=ck_io[28] +#set_property -dict { PACKAGE_PIN R10 IOSTANDARD LVCMOS33 } [get_ports { ck_io29 }]; #IO_25_14 Sch=ck_io[29] +#set_property -dict { PACKAGE_PIN R11 IOSTANDARD LVCMOS33 } [get_ports { ck_io30 }]; #IO_0_14 Sch=ck_io[30] +#set_property -dict { PACKAGE_PIN R13 IOSTANDARD LVCMOS33 } [get_ports { ck_io31 }]; #IO_L5N_T0_D07_14 Sch=ck_io[31] +#set_property -dict { PACKAGE_PIN R15 IOSTANDARD LVCMOS33 } [get_ports { ck_io32 }]; #IO_L13N_T2_MRCC_14 Sch=ck_io[32] +#set_property -dict { PACKAGE_PIN P15 IOSTANDARD LVCMOS33 } [get_ports { ck_io33 }]; #IO_L13P_T2_MRCC_14 Sch=ck_io[33] +#set_property -dict { PACKAGE_PIN R16 IOSTANDARD LVCMOS33 } [get_ports { ck_io34 }]; #IO_L15P_T2_DQS_RDWR_B_14 Sch=ck_io[34] +#set_property -dict { PACKAGE_PIN N16 IOSTANDARD LVCMOS33 } [get_ports { ck_io35 }]; #IO_L11N_T1_SRCC_14 Sch=ck_io[35] +#set_property -dict { PACKAGE_PIN N14 IOSTANDARD LVCMOS33 } [get_ports { ck_io36 }]; #IO_L8P_T1_D11_14 Sch=ck_io[36] +#set_property -dict { PACKAGE_PIN U17 IOSTANDARD LVCMOS33 } [get_ports { ck_io37 }]; #IO_L17P_T2_A14_D30_14 Sch=ck_io[37] +#set_property -dict { PACKAGE_PIN T18 IOSTANDARD LVCMOS33 } [get_ports { ck_io38 }]; #IO_L7N_T1_D10_14 Sch=ck_io[38] +#set_property -dict { PACKAGE_PIN R18 IOSTANDARD LVCMOS33 } [get_ports { ck_io39 }]; #IO_L7P_T1_D09_14 Sch=ck_io[39] +#set_property -dict { PACKAGE_PIN P18 IOSTANDARD LVCMOS33 } [get_ports { ck_io40 }]; #IO_L9N_T1_DQS_D13_14 Sch=ck_io[40] +#set_property -dict { PACKAGE_PIN N17 IOSTANDARD LVCMOS33 } [get_ports { ck_io41 }]; #IO_L9P_T1_DQS_14 Sch=ck_io[41] + +## ChipKit Outer Analog Header - as Single-Ended Analog Inputs +## NOTE: These ports can be used as single-ended analog inputs with voltages from 0-3.3V (ChipKit analog pins A0-A5) or as digital I/O. +## WARNING: Do not use both sets of constraints at the same time! +## NOTE: The following constraints should be used with the XADC IP core when using these ports as analog inputs. +#set_property -dict { PACKAGE_PIN C5 IOSTANDARD LVCMOS33 } [get_ports { vaux4_n }]; #IO_L1N_T0_AD4N_35 Sch=ck_an_n[0] ChipKit pin=A0 +#set_property -dict { PACKAGE_PIN C6 IOSTANDARD LVCMOS33 } [get_ports { vaux4_p }]; #IO_L1P_T0_AD4P_35 Sch=ck_an_p[0] ChipKit pin=A0 +#set_property -dict { PACKAGE_PIN A5 IOSTANDARD LVCMOS33 } [get_ports { vaux5_n }]; #IO_L3N_T0_DQS_AD5N_35 Sch=ck_an_n[1] ChipKit pin=A1 +#set_property -dict { PACKAGE_PIN A6 IOSTANDARD LVCMOS33 } [get_ports { vaux5_p }]; #IO_L3P_T0_DQS_AD5P_35 Sch=ck_an_p[1] ChipKit pin=A1 +#set_property -dict { PACKAGE_PIN B4 IOSTANDARD LVCMOS33 } [get_ports { vaux6_n }]; #IO_L7N_T1_AD6N_35 Sch=ck_an_n[2] ChipKit pin=A2 +#set_property -dict { PACKAGE_PIN C4 IOSTANDARD LVCMOS33 } [get_ports { vaux6_p }]; #IO_L7P_T1_AD6P_35 Sch=ck_an_p[2] ChipKit pin=A2 +#set_property -dict { PACKAGE_PIN A1 IOSTANDARD LVCMOS33 } [get_ports { vaux7_n }]; #IO_L9N_T1_DQS_AD7N_35 Sch=ck_an_n[3] ChipKit pin=A3 +#set_property -dict { PACKAGE_PIN B1 IOSTANDARD LVCMOS33 } [get_ports { vaux7_p }]; #IO_L9P_T1_DQS_AD7P_35 Sch=ck_an_p[3] ChipKit pin=A3 +#set_property -dict { PACKAGE_PIN B2 IOSTANDARD LVCMOS33 } [get_ports { vaux15_n }]; #IO_L10N_T1_AD15N_35 Sch=ck_an_n[4] ChipKit pin=A4 +#set_property -dict { PACKAGE_PIN B3 IOSTANDARD LVCMOS33 } [get_ports { vaux15_p }]; #IO_L10P_T1_AD15P_35 Sch=ck_an_p[4] ChipKit pin=A4 +#set_property -dict { PACKAGE_PIN C14 IOSTANDARD LVCMOS33 } [get_ports { vaux0_n }]; #IO_L1N_T0_AD0N_15 Sch=ck_an_n[5] ChipKit pin=A5 +#set_property -dict { PACKAGE_PIN D14 IOSTANDARD LVCMOS33 } [get_ports { vaux0_p }]; #IO_L1P_T0_AD0P_15 Sch=ck_an_p[5] ChipKit pin=A5 +## ChipKit Outer Analog Header - as Digital I/O +## NOTE: the following constraints should be used when using these ports as digital I/O. +#set_property -dict { PACKAGE_PIN F5 IOSTANDARD LVCMOS33 } [get_ports { ck_a0 }]; #IO_0_35 Sch=ck_a[0] ChipKit pin=A0 +#set_property -dict { PACKAGE_PIN D8 IOSTANDARD LVCMOS33 } [get_ports { ck_a1 }]; #IO_L4P_T0_35 Sch=ck_a[1] ChipKit pin=A1 +#set_property -dict { PACKAGE_PIN C7 IOSTANDARD LVCMOS33 } [get_ports { ck_a2 }]; #IO_L4N_T0_35 Sch=ck_a[2] ChipKit pin=A2 +#set_property -dict { PACKAGE_PIN E7 IOSTANDARD LVCMOS33 } [get_ports { ck_a3 }]; #IO_L6P_T0_35 Sch=ck_a[3] ChipKit pin=A3 +#set_property -dict { PACKAGE_PIN D7 IOSTANDARD LVCMOS33 } [get_ports { ck_a4 }]; #IO_L6N_T0_VREF_35 Sch=ck_a[4] ChipKit pin=A4 +#set_property -dict { PACKAGE_PIN D5 IOSTANDARD LVCMOS33 } [get_ports { ck_a5 }]; #IO_L11P_T1_SRCC_35 Sch=ck_a[5] ChipKit pin=A5 + +## ChipKit Inner Analog Header - as Differential Analog Inputs +## NOTE: These ports can be used as differential analog inputs with voltages from 0-1.0V (ChipKit Analog pins A6-A11) or as digital I/O. +## WARNING: Do not use both sets of constraints at the same time! +## NOTE: The following constraints should be used with the XADC core when using these ports as analog inputs. +#set_property -dict { PACKAGE_PIN B7 IOSTANDARD LVCMOS33 } [get_ports { vaux12_p }]; #IO_L2P_T0_AD12P_35 Sch=ad_p[12] ChipKit pin=A6 +#set_property -dict { PACKAGE_PIN B6 IOSTANDARD LVCMOS33 } [get_ports { vaux12_n }]; #IO_L2N_T0_AD12N_35 Sch=ad_n[12] ChipKit pin=A7 +#set_property -dict { PACKAGE_PIN E6 IOSTANDARD LVCMOS33 } [get_ports { vaux13_p }]; #IO_L5P_T0_AD13P_35 Sch=ad_p[13] ChipKit pin=A8 +#set_property -dict { PACKAGE_PIN E5 IOSTANDARD LVCMOS33 } [get_ports { vaux13_n }]; #IO_L5N_T0_AD13N_35 Sch=ad_n[13] ChipKit pin=A9 +#set_property -dict { PACKAGE_PIN A4 IOSTANDARD LVCMOS33 } [get_ports { vaux14_p }]; #IO_L8P_T1_AD14P_35 Sch=ad_p[14] ChipKit pin=A10 +#set_property -dict { PACKAGE_PIN A3 IOSTANDARD LVCMOS33 } [get_ports { vaux14_n }]; #IO_L8N_T1_AD14N_35 Sch=ad_n[14] ChipKit pin=A11 +## ChipKit Inner Analog Header - as Digital I/O +## NOTE: the following constraints should be used when using the inner analog header ports as digital I/O. +#set_property -dict { PACKAGE_PIN B7 IOSTANDARD LVCMOS33 } [get_ports { ck_io20 }]; #IO_L2P_T0_AD12P_35 Sch=ad_p[12] ChipKit pin=A6 +#set_property -dict { PACKAGE_PIN B6 IOSTANDARD LVCMOS33 } [get_ports { ck_io21 }]; #IO_L2N_T0_AD12N_35 Sch=ad_n[12] ChipKit pin=A7 +#set_property -dict { PACKAGE_PIN E6 IOSTANDARD LVCMOS33 } [get_ports { ck_io22 }]; #IO_L5P_T0_AD13P_35 Sch=ad_p[13] ChipKit pin=A8 +#set_property -dict { PACKAGE_PIN E5 IOSTANDARD LVCMOS33 } [get_ports { ck_io23 }]; #IO_L5N_T0_AD13N_35 Sch=ad_n[13] ChipKit pin=A9 +#set_property -dict { PACKAGE_PIN A4 IOSTANDARD LVCMOS33 } [get_ports { ck_io24 }]; #IO_L8P_T1_AD14P_35 Sch=ad_p[14] ChipKit pin=A10 +#set_property -dict { PACKAGE_PIN A3 IOSTANDARD LVCMOS33 } [get_ports { ck_io25 }]; #IO_L8N_T1_AD14N_35 Sch=ad_n[14] ChipKit pin=A11 + +## ChipKit SPI +#set_property -dict { PACKAGE_PIN G1 IOSTANDARD LVCMOS33 } [get_ports { ck_miso }]; #IO_L17N_T2_35 Sch=ck_miso +#set_property -dict { PACKAGE_PIN H1 IOSTANDARD LVCMOS33 } [get_ports { ck_mosi }]; #IO_L17P_T2_35 Sch=ck_mosi +#set_property -dict { PACKAGE_PIN F1 IOSTANDARD LVCMOS33 } [get_ports { ck_sck }]; #IO_L18P_T2_35 Sch=ck_sck +#set_property -dict { PACKAGE_PIN C1 IOSTANDARD LVCMOS33 } [get_ports { ck_ss }]; #IO_L16N_T2_35 Sch=ck_ss + +## ChipKit I2C +#set_property -dict { PACKAGE_PIN L18 IOSTANDARD LVCMOS33 } [get_ports { ck_scl }]; #IO_L4P_T0_D04_14 Sch=ck_scl +#set_property -dict { PACKAGE_PIN M18 IOSTANDARD LVCMOS33 } [get_ports { ck_sda }]; #IO_L4N_T0_D05_14 Sch=ck_sda +#set_property -dict { PACKAGE_PIN A14 IOSTANDARD LVCMOS33 } [get_ports { scl_pup }]; #IO_L9N_T1_DQS_AD3N_15 Sch=scl_pup +#set_property -dict { PACKAGE_PIN A13 IOSTANDARD LVCMOS33 } [get_ports { sda_pup }]; #IO_L9P_T1_DQS_AD3P_15 Sch=sda_pup + +## Misc. ChipKit Ports +#set_property -dict { PACKAGE_PIN M17 IOSTANDARD LVCMOS33 } [get_ports { ck_ioa }]; #IO_L10N_T1_D15_14 Sch=ck_ioa +set_property -dict {PACKAGE_PIN C2 IOSTANDARD LVCMOS33} [get_ports rst] + +## SMSC Ethernet PHY +#set_property -dict { PACKAGE_PIN D17 IOSTANDARD LVCMOS33 } [get_ports { eth_col }]; #IO_L16N_T2_A27_15 Sch=eth_col +#set_property -dict { PACKAGE_PIN G14 IOSTANDARD LVCMOS33 } [get_ports { eth_crs }]; #IO_L15N_T2_DQS_ADV_B_15 Sch=eth_crs +#set_property -dict { PACKAGE_PIN F16 IOSTANDARD LVCMOS33 } [get_ports { eth_mdc }]; #IO_L14N_T2_SRCC_15 Sch=eth_mdc +#set_property -dict { PACKAGE_PIN K13 IOSTANDARD LVCMOS33 } [get_ports { eth_mdio }]; #IO_L17P_T2_A26_15 Sch=eth_mdio +#set_property -dict { PACKAGE_PIN G18 IOSTANDARD LVCMOS33 } [get_ports { eth_ref_clk }]; #IO_L22P_T3_A17_15 Sch=eth_ref_clk +#set_property -dict { PACKAGE_PIN C16 IOSTANDARD LVCMOS33 } [get_ports { eth_rstn }]; #IO_L20P_T3_A20_15 Sch=eth_rstn +#set_property -dict { PACKAGE_PIN F15 IOSTANDARD LVCMOS33 } [get_ports { eth_rx_clk }]; #IO_L14P_T2_SRCC_15 Sch=eth_rx_clk +#set_property -dict { PACKAGE_PIN G16 IOSTANDARD LVCMOS33 } [get_ports { eth_rx_dv }]; #IO_L13N_T2_MRCC_15 Sch=eth_rx_dv +#set_property -dict { PACKAGE_PIN D18 IOSTANDARD LVCMOS33 } [get_ports { eth_rxd[0] }]; #IO_L21N_T3_DQS_A18_15 Sch=eth_rxd[0] +#set_property -dict { PACKAGE_PIN E17 IOSTANDARD LVCMOS33 } [get_ports { eth_rxd[1] }]; #IO_L16P_T2_A28_15 Sch=eth_rxd[1] +#set_property -dict { PACKAGE_PIN E18 IOSTANDARD LVCMOS33 } [get_ports { eth_rxd[2] }]; #IO_L21P_T3_DQS_15 Sch=eth_rxd[2] +#set_property -dict { PACKAGE_PIN G17 IOSTANDARD LVCMOS33 } [get_ports { eth_rxd[3] }]; #IO_L18N_T2_A23_15 Sch=eth_rxd[3] +#set_property -dict { PACKAGE_PIN C17 IOSTANDARD LVCMOS33 } [get_ports { eth_rxerr }]; #IO_L20N_T3_A19_15 Sch=eth_rxerr +#set_property -dict { PACKAGE_PIN H16 IOSTANDARD LVCMOS33 } [get_ports { eth_tx_clk }]; #IO_L13P_T2_MRCC_15 Sch=eth_tx_clk +#set_property -dict { PACKAGE_PIN H15 IOSTANDARD LVCMOS33 } [get_ports { eth_tx_en }]; #IO_L19N_T3_A21_VREF_15 Sch=eth_tx_en +#set_property -dict { PACKAGE_PIN H14 IOSTANDARD LVCMOS33 } [get_ports { eth_txd[0] }]; #IO_L15P_T2_DQS_15 Sch=eth_txd[0] +#set_property -dict { PACKAGE_PIN J14 IOSTANDARD LVCMOS33 } [get_ports { eth_txd[1] }]; #IO_L19P_T3_A22_15 Sch=eth_txd[1] +#set_property -dict { PACKAGE_PIN J13 IOSTANDARD LVCMOS33 } [get_ports { eth_txd[2] }]; #IO_L17N_T2_A25_15 Sch=eth_txd[2] +#set_property -dict { PACKAGE_PIN H17 IOSTANDARD LVCMOS33 } [get_ports { eth_txd[3] }]; #IO_L18P_T2_A24_15 Sch=eth_txd[3] + +## Quad SPI Flash +#set_property -dict { PACKAGE_PIN L13 IOSTANDARD LVCMOS33 } [get_ports { qspi_cs }]; #IO_L6P_T0_FCS_B_14 Sch=qspi_cs +#set_property -dict { PACKAGE_PIN K17 IOSTANDARD LVCMOS33 } [get_ports { qspi_dq[0] }]; #IO_L1P_T0_D00_MOSI_14 Sch=qspi_dq[0] +#set_property -dict { PACKAGE_PIN K18 IOSTANDARD LVCMOS33 } [get_ports { qspi_dq[1] }]; #IO_L1N_T0_D01_DIN_14 Sch=qspi_dq[1] +#set_property -dict { PACKAGE_PIN L14 IOSTANDARD LVCMOS33 } [get_ports { qspi_dq[2] }]; #IO_L2P_T0_D02_14 Sch=qspi_dq[2] +#set_property -dict { PACKAGE_PIN M14 IOSTANDARD LVCMOS33 } [get_ports { qspi_dq[3] }]; #IO_L2N_T0_D03_14 Sch=qspi_dq[3] + +## Power Measurements +#set_property -dict { PACKAGE_PIN B17 IOSTANDARD LVCMOS33 } [get_ports { vsnsvu_n }]; #IO_L7N_T1_AD2N_15 Sch=ad_n[2] +#set_property -dict { PACKAGE_PIN B16 IOSTANDARD LVCMOS33 } [get_ports { vsnsvu_p }]; #IO_L7P_T1_AD2P_15 Sch=ad_p[2] +#set_property -dict { PACKAGE_PIN B12 IOSTANDARD LVCMOS33 } [get_ports { vsns5v0_n }]; #IO_L3N_T0_DQS_AD1N_15 Sch=ad_n[1] +#set_property -dict { PACKAGE_PIN C12 IOSTANDARD LVCMOS33 } [get_ports { vsns5v0_p }]; #IO_L3P_T0_DQS_AD1P_15 Sch=ad_p[1] +#set_property -dict { PACKAGE_PIN F14 IOSTANDARD LVCMOS33 } [get_ports { isns5v0_n }]; #IO_L5N_T0_AD9N_15 Sch=ad_n[9] +#set_property -dict { PACKAGE_PIN F13 IOSTANDARD LVCMOS33 } [get_ports { isns5v0_p }]; #IO_L5P_T0_AD9P_15 Sch=ad_p[9] +#set_property -dict { PACKAGE_PIN A16 IOSTANDARD LVCMOS33 } [get_ports { isns0v95_n }]; #IO_L8N_T1_AD10N_15 Sch=ad_n[10] +#set_property -dict { PACKAGE_PIN A15 IOSTANDARD LVCMOS33 } [get_ports { isns0v95_p }]; #IO_L8P_T1_AD10P_15 Sch=ad_p[10] + +set_property BITSTREAM.GENERAL.COMPRESS True [current_design] diff --git a/rtl/arty-a7/Arty_C_mig.ucf b/rtl/arty-a7/Arty_C_mig.ucf new file mode 100644 index 0000000..5a36c18 --- /dev/null +++ b/rtl/arty-a7/Arty_C_mig.ucf @@ -0,0 +1,48 @@ +NET "ddr3_dq[0]" LOC = "K5" | IOSTANDARD = SSTL135 ; +NET "ddr3_dq[1]" LOC = "L3" | IOSTANDARD = SSTL135 ; +NET "ddr3_dq[2]" LOC = "K3" | IOSTANDARD = SSTL135 ; +NET "ddr3_dq[3]" LOC = "L6" | IOSTANDARD = SSTL135 ; +NET "ddr3_dq[4]" LOC = "M3" | IOSTANDARD = SSTL135 ; +NET "ddr3_dq[5]" LOC = "M1" | IOSTANDARD = SSTL135 ; +NET "ddr3_dq[6]" LOC = "L4" | IOSTANDARD = SSTL135 ; +NET "ddr3_dq[7]" LOC = "M2" | IOSTANDARD = SSTL135 ; +NET "ddr3_dq[8]" LOC = "V4" | IOSTANDARD = SSTL135 ; +NET "ddr3_dq[9]" LOC = "T5" | IOSTANDARD = SSTL135 ; +NET "ddr3_dq[10]" LOC = "U4" | IOSTANDARD = SSTL135 ; +NET "ddr3_dq[11]" LOC = "V5" | IOSTANDARD = SSTL135 ; +NET "ddr3_dq[12]" LOC = "V1" | IOSTANDARD = SSTL135 ; +NET "ddr3_dq[13]" LOC = "T3" | IOSTANDARD = SSTL135 ; +NET "ddr3_dq[14]" LOC = "U3" | IOSTANDARD = SSTL135 ; +NET "ddr3_dq[15]" LOC = "R3" | IOSTANDARD = SSTL135 ; +NET "ddr3_dm[0]" LOC = "L1" | IOSTANDARD = SSTL135 ; +NET "ddr3_dm[1]" LOC = "U1" | IOSTANDARD = SSTL135 ; +NET "ddr3_dqs_p[0]" LOC = "N2" | IOSTANDARD = DIFF_SSTL135 ; +NET "ddr3_dqs_n[0]" LOC = "N1" | IOSTANDARD = DIFF_SSTL135 ; +NET "ddr3_dqs_p[1]" LOC = "U2" | IOSTANDARD = DIFF_SSTL135 ; +NET "ddr3_dqs_n[1]" LOC = "V2" | IOSTANDARD = DIFF_SSTL135 ; +NET "ddr3_addr[13]" LOC = "T8" | IOSTANDARD = SSTL135 ; +NET "ddr3_addr[12]" LOC = "T6" | IOSTANDARD = SSTL135 ; +NET "ddr3_addr[11]" LOC = "U6" | IOSTANDARD = SSTL135 ; +NET "ddr3_addr[10]" LOC = "R6" | IOSTANDARD = SSTL135 ; +NET "ddr3_addr[9]" LOC = "V7" | IOSTANDARD = SSTL135 ; +NET "ddr3_addr[8]" LOC = "R8" | IOSTANDARD = SSTL135 ; +NET "ddr3_addr[7]" LOC = "U7" | IOSTANDARD = SSTL135 ; +NET "ddr3_addr[6]" LOC = "V6" | IOSTANDARD = SSTL135 ; +NET "ddr3_addr[5]" LOC = "R7" | IOSTANDARD = SSTL135 ; +NET "ddr3_addr[4]" LOC = "N6" | IOSTANDARD = SSTL135 ; +NET "ddr3_addr[3]" LOC = "T1" | IOSTANDARD = SSTL135 ; +NET "ddr3_addr[2]" LOC = "N4" | IOSTANDARD = SSTL135 ; +NET "ddr3_addr[1]" LOC = "M6" | IOSTANDARD = SSTL135 ; +NET "ddr3_addr[0]" LOC = "R2" | IOSTANDARD = SSTL135 ; +NET "ddr3_ba[2]" LOC = "P2" | IOSTANDARD = SSTL135 ; +NET "ddr3_ba[1]" LOC = "P4" | IOSTANDARD = SSTL135 ; +NET "ddr3_ba[0]" LOC = "R1" | IOSTANDARD = SSTL135 ; +NET "ddr3_ck_p[0]" LOC = "U9" | IOSTANDARD = DIFF_SSTL135 ; +NET "ddr3_ck_n[0]" LOC = "V9" | IOSTANDARD = DIFF_SSTL135 ; +NET "ddr3_ras_n" LOC = "P3" | IOSTANDARD = SSTL135 ; +NET "ddr3_cas_n" LOC = "M4" | IOSTANDARD = SSTL135 ; +NET "ddr3_we_n" LOC = "P5" | IOSTANDARD = SSTL135 ; +NET "ddr3_reset_n" LOC = "K6" | IOSTANDARD = SSTL135 ; +NET "ddr3_cke[0]" LOC = "N5" | IOSTANDARD = SSTL135 ; +NET "ddr3_odt[0]" LOC = "R5" | IOSTANDARD = SSTL135 ; +NET "ddr3_cs_n[0]" LOC = "U8" | IOSTANDARD = SSTL135 ; diff --git a/rtl/arty-a7/mig_dram_0/mig_a.prj b/rtl/arty-a7/mig_dram_0/mig_a.prj new file mode 100644 index 0000000..b263a25 --- /dev/null +++ b/rtl/arty-a7/mig_dram_0/mig_a.prj @@ -0,0 +1,148 @@ + + + + + + + + mig_dram_0 + + 1 + + 1 + + OFF + + 1024 + + ON + + Enabled + + xc7a35ti-csg324/-1L + + 4.2 + + No Buffer + + No Buffer + + ACTIVE LOW + + FALSE + + 1 + + 50 Ohms + + 0 + + + DDR3_SDRAM/Components/MT41K128M16XX-15E + 3000 + 1.8V + 4:1 + 83.333 + 0 + 666 + 1.000 + 1 + 1 + 1 + 1 + 16 + 1 + 1 + Disabled + Strict + 4 + FALSE + + 14 + 10 + 3 + 1.35V + BANK_ROW_COLUMN + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 8 - Fixed + Sequential + 5 + Normal + No + Slow Exit + Enable + RZQ/6 + Disable + Enable + RZQ/6 + 0 + Disabled + Enabled + Output Buffer Enabled + Full Array + 5 + Enabled + Normal + Dynamic ODT off + NATIVE + + + + diff --git a/rtl/arty-a7/mig_dram_0/mig_b.prj b/rtl/arty-a7/mig_dram_0/mig_b.prj new file mode 100644 index 0000000..b263a25 --- /dev/null +++ b/rtl/arty-a7/mig_dram_0/mig_b.prj @@ -0,0 +1,148 @@ + + + + + + + + mig_dram_0 + + 1 + + 1 + + OFF + + 1024 + + ON + + Enabled + + xc7a35ti-csg324/-1L + + 4.2 + + No Buffer + + No Buffer + + ACTIVE LOW + + FALSE + + 1 + + 50 Ohms + + 0 + + + DDR3_SDRAM/Components/MT41K128M16XX-15E + 3000 + 1.8V + 4:1 + 83.333 + 0 + 666 + 1.000 + 1 + 1 + 1 + 1 + 16 + 1 + 1 + Disabled + Strict + 4 + FALSE + + 14 + 10 + 3 + 1.35V + BANK_ROW_COLUMN + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 8 - Fixed + Sequential + 5 + Normal + No + Slow Exit + Enable + RZQ/6 + Disable + Enable + RZQ/6 + 0 + Disabled + Enabled + Output Buffer Enabled + Full Array + 5 + Enabled + Normal + Dynamic ODT off + NATIVE + + + + diff --git a/rtl/arty-a7/sdspi_testbench_behav.wcfg b/rtl/arty-a7/sdspi_testbench_behav.wcfg new file mode 100644 index 0000000..bb29917 --- /dev/null +++ b/rtl/arty-a7/sdspi_testbench_behav.wcfg @@ -0,0 +1,176 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + clk + clk + + + tx_data[7:0] + tx_data[7:0] + + + rx_data[7:0] + rx_data[7:0] + + + rx_shifter[7:0] + rx_shifter[7:0] + + + tx_shifter[7:0] + tx_shifter[7:0] + + + tx_fifo_out[7:0] + tx_fifo_out[7:0] + + + tx_fifo_rd_en + tx_fifo_rd_en + + + tx_fifo_wr_en + tx_fifo_wr_en + + + rx_fifo_wr_en + rx_fifo_wr_en + + + rx_bit_recvd + rx_bit_recvd + + + tail_x[4:0] + tail_x[4:0] + + + head_x[4:0] + head_x[4:0] + + + tx_ready + tx_ready + + + tx_empty + tx_empty + + + rx_avail + rx_avail + + + tx_write + tx_write + + + rx_read + rx_read + + + ctrl_write + ctrl_write + + + rx_filter_en + rx_filter_en + + + txrx_en + txrx_en + + + spiclk_div_wr + spiclk_div_wr + + + spi_clk_on + spi_clk_on + + + spiclk_f_en + spiclk_f_en + + + spi_clk_f_on + spi_clk_f_on + + + sd_cs_n + sd_cs_n + #DCDCDC + true + + + sd_mosi + sd_mosi + #00FFFF + true + + + sd_miso + sd_miso + + + sd_sck + sd_sck + #FFFF00 + true + + + xcvr_on + xcvr_on + + + hphase_start + hphase_start + #F0E68C + true + + + clk_phase[1:0] + clk_phase[1:0] + #D2691E + true + + + running + running + + + xcvr_bitcount[3:0] + xcvr_bitcount[3:0] + + + spi_clk_count[6:0] + spi_clk_count[6:0] + + + spi_clk_div[6:0] + spi_clk_div[6:0] + + diff --git a/rtl/arty-a7/testbench_behav1.wcfg b/rtl/arty-a7/testbench_behav1.wcfg new file mode 100644 index 0000000..1a2bc03 --- /dev/null +++ b/rtl/arty-a7/testbench_behav1.wcfg @@ -0,0 +1,88 @@ + + + + + + + + + + + + + + + + + + + + + + + + clk + clk + + + addr[31:0] + addr[31:0] + + + data_in[31:0] + data_in[31:0] + + + data_out[31:0] + data_out[31:0] + + + seq_state[1:0] + seq_state[1:0] + + + PC[31:0] + PC[31:0] + + + nPC[31:0] + nPC[31:0] + + + ins[15:0] + ins[15:0] + BINARYRADIX + + + ins_branch + ins_branch + + + ins_loadrel + ins_loadrel + + + X[31:0] + X[31:0] + + + nX[31:0] + nX[31:0] + + + FP[31:0] + FP[31:0] + + + pc_next_ins[31:0] + pc_next_ins[31:0] + + + mem_wait + mem_wait + + + ins_buf[15:0] + ins_buf[15:0] + + diff --git a/rtl/arty-a7/tridoracpu.tcl b/rtl/arty-a7/tridoracpu.tcl new file mode 100644 index 0000000..46ab1d1 --- /dev/null +++ b/rtl/arty-a7/tridoracpu.tcl @@ -0,0 +1,683 @@ +#***************************************************************************************** +# Vivado (TM) v2020.1 (64-bit) +# +# tridoracpu.tcl: Tcl script for re-creating project 'tridoracpu' +# +# Generated by Vivado on Sat Sep 14 23:58:12 +0200 2024 +# IP Build 2902112 on Wed May 27 22:43:36 MDT 2020 +# +# This file contains the Vivado Tcl commands for re-creating the project to the state* +# when this script was generated. In order to re-create the project, please source this +# file in the Vivado Tcl Shell. +# +# * Note that the runs in the created project will be configured the same way as the +# original project, however they will not be launched automatically. To regenerate the +# run results please launch the synthesis/implementation runs as needed. +# +#***************************************************************************************** + +# uncomment next two statements if you have never initialized the Xilinx Board Store +# this will take quite some time +#xhub::refresh_catalog [xhub::get_xstores xilinx_board_store] +#xhub::install [xhub::get_xitems] + +# Set the reference directory for source file relative paths +set origin_dir "change_this_to_your_rtl_directory" + +set xilinx_board_store_dir [get_property LOCAL_ROOT_DIR [xhub::get_xstores xilinx_board_store]] +set_param board.repoPaths [get_property LOCAL_ROOT_DIR [xhub::get_xstores xilinx_board_store]] + +# Use origin directory path location variable, if specified in the tcl shell +if { [info exists ::origin_dir_loc] } { + set origin_dir $::origin_dir_loc +} + +# Set the project name +set _xil_proj_name_ "tridoracpu" + +# Use project name variable, if specified in the tcl shell +if { [info exists ::user_project_name] } { + set _xil_proj_name_ $::user_project_name +} + +variable script_file +set script_file "tridoracpu.tcl" + +# Help information for this script +proc print_help {} { + variable script_file + puts "\nDescription:" + puts "Recreate a Vivado project from this script. The created project will be" + puts "functionally equivalent to the original project for which this script was" + puts "generated. The script contains commands for creating a project, filesets," + puts "runs, adding/importing sources and setting properties on various objects.\n" + puts "Syntax:" + puts "$script_file" + puts "$script_file -tclargs \[--origin_dir \]" + puts "$script_file -tclargs \[--project_name \]" + puts "$script_file -tclargs \[--help\]\n" + puts "Usage:" + puts "Name Description" + puts "-------------------------------------------------------------------------" + puts "\[--origin_dir \] Determine source file paths wrt this path. Default" + puts " origin_dir path value is \".\", otherwise, the value" + puts " that was set with the \"-paths_relative_to\" switch" + puts " when this script was generated.\n" + puts "\[--project_name \] Create project with the specified name. Default" + puts " name is the name of the project from where this" + puts " script was generated.\n" + puts "\[--help\] Print help information for this script" + puts "-------------------------------------------------------------------------\n" + exit 0 +} + +if { $::argc > 0 } { + for {set i 0} {$i < $::argc} {incr i} { + set option [string trim [lindex $::argv $i]] + switch -regexp -- $option { + "--origin_dir" { incr i; set origin_dir [lindex $::argv $i] } + "--project_name" { incr i; set _xil_proj_name_ [lindex $::argv $i] } + "--help" { print_help } + default { + if { [regexp {^-} $option] } { + puts "ERROR: Unknown option '$option' specified, please type '$script_file -tclargs --help' for usage info.\n" + return 1 + } + } + } + } +} + +# Set the directory path for the original project from where this script was exported +set orig_proj_dir "[file normalize "${origin_dir}/arty-a7"]" + +# Create project +create_project ${_xil_proj_name_} ./${_xil_proj_name_} -part xc7a35ticsg324-1L + +# Set the directory path for the new project +set proj_dir [get_property directory [current_project]] + +# Set project properties +set obj [current_project] +#set_property -name "board_part_repo_paths" -value "[file normalize "$xilinx_board_store_dir"]" -objects $obj +set_property -name "board_part" -value "digilentinc.com:arty-a7-35:part0:1.0" -objects $obj +set_property -name "default_lib" -value "xil_defaultlib" -objects $obj +set_property -name "enable_vhdl_2008" -value "1" -objects $obj +set_property -name "ip_cache_permissions" -value "read write" -objects $obj +set_property -name "ip_output_repo" -value "$proj_dir/${_xil_proj_name_}.cache/ip" -objects $obj +set_property -name "mem.enable_memory_map_generation" -value "1" -objects $obj +set_property -name "platform.board_id" -value "arty-a7-35" -objects $obj +set_property -name "sim.central_dir" -value "$proj_dir/${_xil_proj_name_}.ip_user_files" -objects $obj +set_property -name "sim.ip.auto_export_scripts" -value "1" -objects $obj +set_property -name "simulator_language" -value "Mixed" -objects $obj +set_property -name "source_mgmt_mode" -value "DisplayOnly" -objects $obj +set_property -name "webtalk.activehdl_export_sim" -value "4" -objects $obj +set_property -name "webtalk.ies_export_sim" -value "4" -objects $obj +set_property -name "webtalk.modelsim_export_sim" -value "4" -objects $obj +set_property -name "webtalk.questa_export_sim" -value "4" -objects $obj +set_property -name "webtalk.riviera_export_sim" -value "4" -objects $obj +set_property -name "webtalk.vcs_export_sim" -value "4" -objects $obj +set_property -name "webtalk.xsim_export_sim" -value "4" -objects $obj +set_property -name "webtalk.xsim_launch_sim" -value "537" -objects $obj + +# Create 'sources_1' fileset (if not found) +if {[string equal [get_filesets -quiet sources_1] ""]} { + create_fileset -srcset sources_1 +} + +# Set 'sources_1' fileset object +set obj [get_filesets sources_1] +set files [list \ + [file normalize "${origin_dir}/src/uart.v"] \ +] +add_files -norecurse -fileset $obj $files + +# Add local files from the original project (-no_copy_sources specified) +set files [list \ + [file normalize "${origin_dir}/src/cpuclk.v" ]\ + [file normalize "${origin_dir}/src/display_clock.v" ]\ + [file normalize "${origin_dir}/src/mem.v" ]\ + [file normalize "${origin_dir}/src/stack.v" ]\ + [file normalize "${origin_dir}/src/stackcpu.v" ]\ + [file normalize "${origin_dir}/src/vgafb.v" ]\ + [file normalize "${origin_dir}/src/top.v" ]\ + [file normalize "${origin_dir}/src/testbench.v" ]\ + [file normalize "${orig_proj_dir}/rom.mem" ]\ + [file normalize "${orig_proj_dir}/mig_dram_0/mig_a.prj" ]\ + [file normalize "${orig_proj_dir}/mig_dram_0/mig_b.prj" ]\ + [file normalize "${origin_dir}/src/dram_bridge.v" ]\ + [file normalize "${origin_dir}/src/sdspi.v" ]\ + [file normalize "${origin_dir}/src/bram_tdp.v" ]\ + [file normalize "${origin_dir}/src/palette.v" ]\ + [file normalize "${origin_dir}/src/irqctrl.v" ]\ + [file normalize "${origin_dir}/src/fifo.v" ]\ + [file normalize "${origin_dir}/src/fifo_testbench.v" ]\ + [file normalize "${origin_dir}/src/sdspi_testbench.v" ]\ +] +set added_files [add_files -fileset sources_1 $files] + +# Set 'sources_1' fileset file properties for remote files +set file "$origin_dir/src/uart.v" +set file [file normalize $file] +set file_obj [get_files -of_objects [get_filesets sources_1] [list "*$file"]] +set_property -name "used_in" -value "synthesis implementation" -objects $file_obj +set_property -name "used_in_simulation" -value "0" -objects $file_obj + + +# Set 'sources_1' fileset file properties for local files +set file "src/cpuclk.v" +set file_obj [get_files -of_objects [get_filesets sources_1] [list "*$file"]] +set_property -name "used_in" -value "synthesis implementation" -objects $file_obj +set_property -name "used_in_simulation" -value "0" -objects $file_obj + +set file "src/display_clock.v" +set file_obj [get_files -of_objects [get_filesets sources_1] [list "*$file"]] +set_property -name "is_enabled" -value "0" -objects $file_obj + +set file "src/mem.v" +set file_obj [get_files -of_objects [get_filesets sources_1] [list "*$file"]] +set_property -name "used_in" -value "synthesis implementation" -objects $file_obj +set_property -name "used_in_simulation" -value "0" -objects $file_obj + +set file "src/stack.v" +set file_obj [get_files -of_objects [get_filesets sources_1] [list "*$file"]] +set_property -name "used_in" -value "synthesis implementation" -objects $file_obj +set_property -name "used_in_simulation" -value "0" -objects $file_obj + +set file "src/stackcpu.v" +set file_obj [get_files -of_objects [get_filesets sources_1] [list "*$file"]] +set_property -name "used_in" -value "synthesis implementation" -objects $file_obj +set_property -name "used_in_simulation" -value "0" -objects $file_obj + +set file "src/vgafb.v" +set file_obj [get_files -of_objects [get_filesets sources_1] [list "*$file"]] +set_property -name "used_in" -value "synthesis implementation" -objects $file_obj +set_property -name "used_in_simulation" -value "0" -objects $file_obj + +set file "src/top.v" +set file_obj [get_files -of_objects [get_filesets sources_1] [list "*$file"]] +set_property -name "used_in" -value "synthesis implementation" -objects $file_obj +set_property -name "used_in_simulation" -value "0" -objects $file_obj + +set file "src/testbench.v" +set file_obj [get_files -of_objects [get_filesets sources_1] [list "*$file"]] +set_property -name "used_in" -value "" -objects $file_obj +set_property -name "used_in_implementation" -value "0" -objects $file_obj +set_property -name "used_in_simulation" -value "0" -objects $file_obj +set_property -name "used_in_synthesis" -value "0" -objects $file_obj + +set file "arty-a7/rom.mem" +set file_obj [get_files -of_objects [get_filesets sources_1] [list "*$file"]] +set_property -name "file_type" -value "Memory File" -objects $file_obj + +set file "arty-a7/mig_dram_0/mig_a.prj" +set file_obj [get_files -of_objects [get_filesets sources_1] [list "*$file"]] +set_property -name "scoped_to_cells" -value "mig_dram_0" -objects $file_obj + +set file "arty-a7/mig_dram_0/mig_b.prj" +set file_obj [get_files -of_objects [get_filesets sources_1] [list "*$file"]] +set_property -name "scoped_to_cells" -value "mig_dram_0" -objects $file_obj + +set file "src/dram_bridge.v" +set file_obj [get_files -of_objects [get_filesets sources_1] [list "*$file"]] +set_property -name "used_in" -value "synthesis implementation" -objects $file_obj +set_property -name "used_in_simulation" -value "0" -objects $file_obj + +set file "src/palette.v" +set file_obj [get_files -of_objects [get_filesets sources_1] [list "*$file"]] +set_property -name "used_in" -value "synthesis implementation" -objects $file_obj +set_property -name "used_in_simulation" -value "0" -objects $file_obj + +set file "src/irqctrl.v" +set file_obj [get_files -of_objects [get_filesets sources_1] [list "*$file"]] +set_property -name "used_in" -value "synthesis implementation" -objects $file_obj +set_property -name "used_in_simulation" -value "0" -objects $file_obj + +set file "src/fifo_testbench.v" +set file_obj [get_files -of_objects [get_filesets sources_1] [list "*$file"]] +set_property -name "used_in" -value "" -objects $file_obj +set_property -name "used_in_implementation" -value "0" -objects $file_obj +set_property -name "used_in_simulation" -value "0" -objects $file_obj +set_property -name "used_in_synthesis" -value "0" -objects $file_obj + + +# Set 'sources_1' fileset properties +set obj [get_filesets sources_1] +set_property -name "top" -value "top" -objects $obj +set_property -name "top_auto_set" -value "0" -objects $obj + +# Set 'sources_1' fileset object +set obj [get_filesets sources_1] +# Add local files from the original project (-no_copy_sources specified) +set files [list \ + [file normalize "${orig_proj_dir}/mig_dram_0/mig_dram_0.xci" ]\ +] +set added_files [add_files -fileset sources_1 $files] + +# Set 'sources_1' fileset file properties for remote files +# None + +# Set 'sources_1' fileset file properties for local files +set file "arty-a7/mig_dram_0/mig_dram_0.xci" +set file_obj [get_files -of_objects [get_filesets sources_1] [list "*$file"]] +set_property -name "generate_files_for_reference" -value "0" -objects $file_obj +set_property -name "registered_with_manager" -value "1" -objects $file_obj +if { ![get_property "is_locked" $file_obj] } { + set_property -name "synth_checkpoint_mode" -value "Singular" -objects $file_obj +} +set_property -name "used_in" -value "synthesis implementation" -objects $file_obj +set_property -name "used_in_simulation" -value "0" -objects $file_obj + + +# Create 'constrs_1' fileset (if not found) +if {[string equal [get_filesets -quiet constrs_1] ""]} { + create_fileset -constrset constrs_1 +} + +# Set 'constrs_1' fileset object +set obj [get_filesets constrs_1] + +# Add/Import constrs file and set constrs file properties +set file "[file normalize ${origin_dir}/arty-a7/Arty-A7-35-Master.xdc]" +set file_added [add_files -norecurse -fileset $obj [list $file]] +set file "$origin_dir/arty-a7/Arty-A7-35-Master.xdc" +set file [file normalize $file] +set file_obj [get_files -of_objects [get_filesets constrs_1] [list "*$file"]] +set_property -name "file_type" -value "XDC" -objects $file_obj + +# Set 'constrs_1' fileset properties +set obj [get_filesets constrs_1] +set_property -name "target_constrs_file" -value "$orig_proj_dir/Arty-A7-35-Master.xdc" -objects $obj +set_property -name "target_ucf" -value "$orig_proj_dir/Arty-A7-35-Master.xdc" -objects $obj + +# Create 'sim_1' fileset (if not found) +if {[string equal [get_filesets -quiet sim_1] ""]} { + create_fileset -simset sim_1 +} + +# Set 'sim_1' fileset object +set obj [get_filesets sim_1] +# Add local files from the original project (-no_copy_sources specified) +set files [list \ + [file normalize "${origin_dir}/src/uart_tb.v" ]\ + [file normalize "${orig_proj_dir}/testbench_behav1.wcfg" ]\ +] +set added_files [add_files -fileset sim_1 $files] + +# Set 'sim_1' fileset file properties for remote files +# None + +# Set 'sim_1' fileset file properties for local files +set file [file normalize "${origin_dir}/src/uart_tb.v"] +set file_obj [get_files -of_objects [get_filesets sim_1] [list "*$file"]] +set_property -name "used_in" -value "" -objects $file_obj +set_property -name "used_in_implementation" -value "0" -objects $file_obj +set_property -name "used_in_simulation" -value "0" -objects $file_obj +set_property -name "used_in_synthesis" -value "0" -objects $file_obj + + +# Set 'sim_1' fileset properties +set obj [get_filesets sim_1] +set_property -name "hbs.configure_design_for_hier_access" -value "1" -objects $obj +set_property -name "nl.mode" -value "funcsim" -objects $obj +set_property -name "top" -value "testbench" -objects $obj +set_property -name "top_lib" -value "xil_defaultlib" -objects $obj + +# Create 'sim_fifo' fileset (if not found) +if {[string equal [get_filesets -quiet sim_fifo] ""]} { + create_fileset -simset sim_fifo +} + +# Set 'sim_fifo' fileset object +set obj [get_filesets sim_fifo] +# Add local files from the original project (-no_copy_sources specified) +set files [list \ + [file normalize "${origin_dir}/src/fifo.v" ]\ + [file normalize "${origin_dir}/src/fifo_testbench.v" ]\ +] +set added_files [add_files -fileset sim_fifo $files] + +# Set 'sim_fifo' fileset file properties for remote files +# None + +# Set 'sim_fifo' fileset file properties for local files +# None + +# Set 'sim_fifo' fileset properties +set obj [get_filesets sim_fifo] +set_property -name "hbs.configure_design_for_hier_access" -value "1" -objects $obj +set_property -name "top" -value "fifo_testbench" -objects $obj +set_property -name "top_auto_set" -value "0" -objects $obj + +# Create 'sim_sdspi' fileset (if not found) +if {[string equal [get_filesets -quiet sim_sdspi] ""]} { + create_fileset -simset sim_sdspi +} + +# Set 'sim_sdspi' fileset object +set obj [get_filesets sim_sdspi] +# Add local files from the original project (-no_copy_sources specified) +set files [list \ + [file normalize "${orig_proj_dir}/sdspi_testbench_behav.wcfg" ]\ +] +set added_files [add_files -fileset sim_sdspi $files] + +# Set 'sim_sdspi' fileset file properties for remote files +# None + +# Set 'sim_sdspi' fileset file properties for local files +# None + +# Set 'sim_sdspi' fileset properties +set obj [get_filesets sim_sdspi] +set_property -name "hbs.configure_design_for_hier_access" -value "1" -objects $obj +set_property -name "sim_mode" -value "post-synthesis" -objects $obj +set_property -name "top" -value "sdspi_testbench" -objects $obj +set_property -name "top_auto_set" -value "0" -objects $obj +set_property -name "top_lib" -value "xil_defaultlib" -objects $obj +set_property -name "xsim.simulate.runtime" -value "10ms" -objects $obj + +# Set 'utils_1' fileset object +set obj [get_filesets utils_1] +# Empty (no sources present) + +# Set 'utils_1' fileset properties +set obj [get_filesets utils_1] + +# Create 'synth_1' run (if not found) +if {[string equal [get_runs -quiet synth_1] ""]} { + create_run -name synth_1 -part xc7a35ticsg324-1L -flow {Vivado Synthesis 2020} -strategy "Vivado Synthesis Defaults" -report_strategy {No Reports} -constrset constrs_1 +} else { + set_property strategy "Vivado Synthesis Defaults" [get_runs synth_1] + set_property flow "Vivado Synthesis 2020" [get_runs synth_1] +} +set obj [get_runs synth_1] +set_property set_report_strategy_name 1 $obj +set_property report_strategy {Vivado Synthesis Default Reports} $obj +set_property set_report_strategy_name 0 $obj +# Create 'synth_1_synth_report_utilization_0' report (if not found) +if { [ string equal [get_report_configs -of_objects [get_runs synth_1] synth_1_synth_report_utilization_0] "" ] } { + create_report_config -report_name synth_1_synth_report_utilization_0 -report_type report_utilization:1.0 -steps synth_design -runs synth_1 +} +set obj [get_report_configs -of_objects [get_runs synth_1] synth_1_synth_report_utilization_0] +if { $obj != "" } { + +} +set obj [get_runs synth_1] +set_property -name "needs_refresh" -value "1" -objects $obj +set_property -name "strategy" -value "Vivado Synthesis Defaults" -objects $obj + +# set the current synth run +current_run -synthesis [get_runs synth_1] + +# Create 'impl_1' run (if not found) +if {[string equal [get_runs -quiet impl_1] ""]} { + create_run -name impl_1 -part xc7a35ticsg324-1L -flow {Vivado Implementation 2020} -strategy "Performance_RefinePlacement" -report_strategy {No Reports} -constrset constrs_1 -parent_run synth_1 +} else { + set_property strategy "Performance_RefinePlacement" [get_runs impl_1] + set_property flow "Vivado Implementation 2020" [get_runs impl_1] +} +set obj [get_runs impl_1] +set_property set_report_strategy_name 1 $obj +set_property report_strategy {Vivado Implementation Default Reports} $obj +set_property set_report_strategy_name 0 $obj +# Create 'impl_1_init_report_timing_summary_0' report (if not found) +if { [ string equal [get_report_configs -of_objects [get_runs impl_1] impl_1_init_report_timing_summary_0] "" ] } { + create_report_config -report_name impl_1_init_report_timing_summary_0 -report_type report_timing_summary:1.0 -steps init_design -runs impl_1 +} +set obj [get_report_configs -of_objects [get_runs impl_1] impl_1_init_report_timing_summary_0] +if { $obj != "" } { +set_property -name "is_enabled" -value "0" -objects $obj +set_property -name "options.max_paths" -value "10" -objects $obj + +} +# Create 'impl_1_opt_report_drc_0' report (if not found) +if { [ string equal [get_report_configs -of_objects [get_runs impl_1] impl_1_opt_report_drc_0] "" ] } { + create_report_config -report_name impl_1_opt_report_drc_0 -report_type report_drc:1.0 -steps opt_design -runs impl_1 +} +set obj [get_report_configs -of_objects [get_runs impl_1] impl_1_opt_report_drc_0] +if { $obj != "" } { + +} +# Create 'impl_1_opt_report_timing_summary_0' report (if not found) +if { [ string equal [get_report_configs -of_objects [get_runs impl_1] impl_1_opt_report_timing_summary_0] "" ] } { + create_report_config -report_name impl_1_opt_report_timing_summary_0 -report_type report_timing_summary:1.0 -steps opt_design -runs impl_1 +} +set obj [get_report_configs -of_objects [get_runs impl_1] impl_1_opt_report_timing_summary_0] +if { $obj != "" } { +set_property -name "is_enabled" -value "0" -objects $obj +set_property -name "options.max_paths" -value "10" -objects $obj + +} +# Create 'impl_1_power_opt_report_timing_summary_0' report (if not found) +if { [ string equal [get_report_configs -of_objects [get_runs impl_1] impl_1_power_opt_report_timing_summary_0] "" ] } { + create_report_config -report_name impl_1_power_opt_report_timing_summary_0 -report_type report_timing_summary:1.0 -steps power_opt_design -runs impl_1 +} +set obj [get_report_configs -of_objects [get_runs impl_1] impl_1_power_opt_report_timing_summary_0] +if { $obj != "" } { +set_property -name "is_enabled" -value "0" -objects $obj +set_property -name "options.max_paths" -value "10" -objects $obj + +} +# Create 'impl_1_place_report_io_0' report (if not found) +if { [ string equal [get_report_configs -of_objects [get_runs impl_1] impl_1_place_report_io_0] "" ] } { + create_report_config -report_name impl_1_place_report_io_0 -report_type report_io:1.0 -steps place_design -runs impl_1 +} +set obj [get_report_configs -of_objects [get_runs impl_1] impl_1_place_report_io_0] +if { $obj != "" } { + +} +# Create 'impl_1_place_report_utilization_0' report (if not found) +if { [ string equal [get_report_configs -of_objects [get_runs impl_1] impl_1_place_report_utilization_0] "" ] } { + create_report_config -report_name impl_1_place_report_utilization_0 -report_type report_utilization:1.0 -steps place_design -runs impl_1 +} +set obj [get_report_configs -of_objects [get_runs impl_1] impl_1_place_report_utilization_0] +if { $obj != "" } { + +} +# Create 'impl_1_place_report_control_sets_0' report (if not found) +if { [ string equal [get_report_configs -of_objects [get_runs impl_1] impl_1_place_report_control_sets_0] "" ] } { + create_report_config -report_name impl_1_place_report_control_sets_0 -report_type report_control_sets:1.0 -steps place_design -runs impl_1 +} +set obj [get_report_configs -of_objects [get_runs impl_1] impl_1_place_report_control_sets_0] +if { $obj != "" } { +set_property -name "options.verbose" -value "1" -objects $obj + +} +# Create 'impl_1_place_report_incremental_reuse_0' report (if not found) +if { [ string equal [get_report_configs -of_objects [get_runs impl_1] impl_1_place_report_incremental_reuse_0] "" ] } { + create_report_config -report_name impl_1_place_report_incremental_reuse_0 -report_type report_incremental_reuse:1.0 -steps place_design -runs impl_1 +} +set obj [get_report_configs -of_objects [get_runs impl_1] impl_1_place_report_incremental_reuse_0] +if { $obj != "" } { +set_property -name "is_enabled" -value "0" -objects $obj + +} +# Create 'impl_1_place_report_incremental_reuse_1' report (if not found) +if { [ string equal [get_report_configs -of_objects [get_runs impl_1] impl_1_place_report_incremental_reuse_1] "" ] } { + create_report_config -report_name impl_1_place_report_incremental_reuse_1 -report_type report_incremental_reuse:1.0 -steps place_design -runs impl_1 +} +set obj [get_report_configs -of_objects [get_runs impl_1] impl_1_place_report_incremental_reuse_1] +if { $obj != "" } { +set_property -name "is_enabled" -value "0" -objects $obj + +} +# Create 'impl_1_place_report_timing_summary_0' report (if not found) +if { [ string equal [get_report_configs -of_objects [get_runs impl_1] impl_1_place_report_timing_summary_0] "" ] } { + create_report_config -report_name impl_1_place_report_timing_summary_0 -report_type report_timing_summary:1.0 -steps place_design -runs impl_1 +} +set obj [get_report_configs -of_objects [get_runs impl_1] impl_1_place_report_timing_summary_0] +if { $obj != "" } { +set_property -name "is_enabled" -value "0" -objects $obj +set_property -name "options.max_paths" -value "10" -objects $obj + +} +# Create 'impl_1_post_place_power_opt_report_timing_summary_0' report (if not found) +if { [ string equal [get_report_configs -of_objects [get_runs impl_1] impl_1_post_place_power_opt_report_timing_summary_0] "" ] } { + create_report_config -report_name impl_1_post_place_power_opt_report_timing_summary_0 -report_type report_timing_summary:1.0 -steps post_place_power_opt_design -runs impl_1 +} +set obj [get_report_configs -of_objects [get_runs impl_1] impl_1_post_place_power_opt_report_timing_summary_0] +if { $obj != "" } { +set_property -name "is_enabled" -value "0" -objects $obj +set_property -name "options.max_paths" -value "10" -objects $obj + +} +# Create 'impl_1_phys_opt_report_timing_summary_0' report (if not found) +if { [ string equal [get_report_configs -of_objects [get_runs impl_1] impl_1_phys_opt_report_timing_summary_0] "" ] } { + create_report_config -report_name impl_1_phys_opt_report_timing_summary_0 -report_type report_timing_summary:1.0 -steps phys_opt_design -runs impl_1 +} +set obj [get_report_configs -of_objects [get_runs impl_1] impl_1_phys_opt_report_timing_summary_0] +if { $obj != "" } { +set_property -name "is_enabled" -value "0" -objects $obj +set_property -name "options.max_paths" -value "10" -objects $obj + +} +# Create 'impl_1_route_report_drc_0' report (if not found) +if { [ string equal [get_report_configs -of_objects [get_runs impl_1] impl_1_route_report_drc_0] "" ] } { + create_report_config -report_name impl_1_route_report_drc_0 -report_type report_drc:1.0 -steps route_design -runs impl_1 +} +set obj [get_report_configs -of_objects [get_runs impl_1] impl_1_route_report_drc_0] +if { $obj != "" } { + +} +# Create 'impl_1_route_report_methodology_0' report (if not found) +if { [ string equal [get_report_configs -of_objects [get_runs impl_1] impl_1_route_report_methodology_0] "" ] } { + create_report_config -report_name impl_1_route_report_methodology_0 -report_type report_methodology:1.0 -steps route_design -runs impl_1 +} +set obj [get_report_configs -of_objects [get_runs impl_1] impl_1_route_report_methodology_0] +if { $obj != "" } { + +} +# Create 'impl_1_route_report_power_0' report (if not found) +if { [ string equal [get_report_configs -of_objects [get_runs impl_1] impl_1_route_report_power_0] "" ] } { + create_report_config -report_name impl_1_route_report_power_0 -report_type report_power:1.0 -steps route_design -runs impl_1 +} +set obj [get_report_configs -of_objects [get_runs impl_1] impl_1_route_report_power_0] +if { $obj != "" } { + +} +# Create 'impl_1_route_report_route_status_0' report (if not found) +if { [ string equal [get_report_configs -of_objects [get_runs impl_1] impl_1_route_report_route_status_0] "" ] } { + create_report_config -report_name impl_1_route_report_route_status_0 -report_type report_route_status:1.0 -steps route_design -runs impl_1 +} +set obj [get_report_configs -of_objects [get_runs impl_1] impl_1_route_report_route_status_0] +if { $obj != "" } { + +} +# Create 'impl_1_route_report_timing_summary_0' report (if not found) +if { [ string equal [get_report_configs -of_objects [get_runs impl_1] impl_1_route_report_timing_summary_0] "" ] } { + create_report_config -report_name impl_1_route_report_timing_summary_0 -report_type report_timing_summary:1.0 -steps route_design -runs impl_1 +} +set obj [get_report_configs -of_objects [get_runs impl_1] impl_1_route_report_timing_summary_0] +if { $obj != "" } { +set_property -name "options.max_paths" -value "10" -objects $obj + +} +# Create 'impl_1_route_report_incremental_reuse_0' report (if not found) +if { [ string equal [get_report_configs -of_objects [get_runs impl_1] impl_1_route_report_incremental_reuse_0] "" ] } { + create_report_config -report_name impl_1_route_report_incremental_reuse_0 -report_type report_incremental_reuse:1.0 -steps route_design -runs impl_1 +} +set obj [get_report_configs -of_objects [get_runs impl_1] impl_1_route_report_incremental_reuse_0] +if { $obj != "" } { + +} +# Create 'impl_1_route_report_clock_utilization_0' report (if not found) +if { [ string equal [get_report_configs -of_objects [get_runs impl_1] impl_1_route_report_clock_utilization_0] "" ] } { + create_report_config -report_name impl_1_route_report_clock_utilization_0 -report_type report_clock_utilization:1.0 -steps route_design -runs impl_1 +} +set obj [get_report_configs -of_objects [get_runs impl_1] impl_1_route_report_clock_utilization_0] +if { $obj != "" } { + +} +# Create 'impl_1_route_report_bus_skew_0' report (if not found) +if { [ string equal [get_report_configs -of_objects [get_runs impl_1] impl_1_route_report_bus_skew_0] "" ] } { + create_report_config -report_name impl_1_route_report_bus_skew_0 -report_type report_bus_skew:1.1 -steps route_design -runs impl_1 +} +set obj [get_report_configs -of_objects [get_runs impl_1] impl_1_route_report_bus_skew_0] +if { $obj != "" } { +set_property -name "options.warn_on_violation" -value "1" -objects $obj + +} +# Create 'impl_1_post_route_phys_opt_report_timing_summary_0' report (if not found) +if { [ string equal [get_report_configs -of_objects [get_runs impl_1] impl_1_post_route_phys_opt_report_timing_summary_0] "" ] } { + create_report_config -report_name impl_1_post_route_phys_opt_report_timing_summary_0 -report_type report_timing_summary:1.0 -steps post_route_phys_opt_design -runs impl_1 +} +set obj [get_report_configs -of_objects [get_runs impl_1] impl_1_post_route_phys_opt_report_timing_summary_0] +if { $obj != "" } { +set_property -name "options.max_paths" -value "10" -objects $obj +set_property -name "options.warn_on_violation" -value "1" -objects $obj + +} +# Create 'impl_1_post_route_phys_opt_report_bus_skew_0' report (if not found) +if { [ string equal [get_report_configs -of_objects [get_runs impl_1] impl_1_post_route_phys_opt_report_bus_skew_0] "" ] } { + create_report_config -report_name impl_1_post_route_phys_opt_report_bus_skew_0 -report_type report_bus_skew:1.1 -steps post_route_phys_opt_design -runs impl_1 +} +set obj [get_report_configs -of_objects [get_runs impl_1] impl_1_post_route_phys_opt_report_bus_skew_0] +if { $obj != "" } { +set_property -name "options.warn_on_violation" -value "1" -objects $obj + +} +set obj [get_runs impl_1] +set_property -name "needs_refresh" -value "1" -objects $obj +set_property -name "strategy" -value "Performance_RefinePlacement" -objects $obj +set_property -name "steps.place_design.args.directive" -value "ExtraPostPlacementOpt" -objects $obj +set_property -name "steps.phys_opt_design.args.directive" -value "Explore" -objects $obj +set_property -name "steps.route_design.args.directive" -value "Explore" -objects $obj +set_property -name "steps.write_bitstream.args.bin_file" -value "1" -objects $obj +set_property -name "steps.write_bitstream.args.readback_file" -value "0" -objects $obj +set_property -name "steps.write_bitstream.args.verbose" -value "0" -objects $obj + +# set the current impl run +current_run -implementation [get_runs impl_1] + +puts "INFO: Project created:${_xil_proj_name_}" +# Create 'drc_1' gadget (if not found) +if {[string equal [get_dashboard_gadgets [ list "drc_1" ] ] ""]} { +create_dashboard_gadget -name {drc_1} -type drc +} +set obj [get_dashboard_gadgets [ list "drc_1" ] ] +set_property -name "reports" -value "impl_1#impl_1_route_report_drc_0" -objects $obj + +# Create 'methodology_1' gadget (if not found) +if {[string equal [get_dashboard_gadgets [ list "methodology_1" ] ] ""]} { +create_dashboard_gadget -name {methodology_1} -type methodology +} +set obj [get_dashboard_gadgets [ list "methodology_1" ] ] +set_property -name "reports" -value "impl_1#impl_1_route_report_methodology_0" -objects $obj + +# Create 'power_1' gadget (if not found) +if {[string equal [get_dashboard_gadgets [ list "power_1" ] ] ""]} { +create_dashboard_gadget -name {power_1} -type power +} +set obj [get_dashboard_gadgets [ list "power_1" ] ] +set_property -name "reports" -value "impl_1#impl_1_route_report_power_0" -objects $obj + +# Create 'timing_1' gadget (if not found) +if {[string equal [get_dashboard_gadgets [ list "timing_1" ] ] ""]} { +create_dashboard_gadget -name {timing_1} -type timing +} +set obj [get_dashboard_gadgets [ list "timing_1" ] ] +set_property -name "reports" -value "impl_1#impl_1_route_report_timing_summary_0" -objects $obj + +# Create 'utilization_1' gadget (if not found) +if {[string equal [get_dashboard_gadgets [ list "utilization_1" ] ] ""]} { +create_dashboard_gadget -name {utilization_1} -type utilization +} +set obj [get_dashboard_gadgets [ list "utilization_1" ] ] +set_property -name "reports" -value "synth_1#synth_1_synth_report_utilization_0" -objects $obj +set_property -name "run.step" -value "synth_design" -objects $obj +set_property -name "run.type" -value "synthesis" -objects $obj + +# Create 'utilization_2' gadget (if not found) +if {[string equal [get_dashboard_gadgets [ list "utilization_2" ] ] ""]} { +create_dashboard_gadget -name {utilization_2} -type utilization +} +set obj [get_dashboard_gadgets [ list "utilization_2" ] ] +set_property -name "reports" -value "impl_1#impl_1_place_report_utilization_0" -objects $obj + +move_dashboard_gadget -name {utilization_1} -row 0 -col 0 +move_dashboard_gadget -name {power_1} -row 1 -col 0 +move_dashboard_gadget -name {drc_1} -row 2 -col 0 +move_dashboard_gadget -name {timing_1} -row 0 -col 1 +move_dashboard_gadget -name {utilization_2} -row 1 -col 1 +move_dashboard_gadget -name {methodology_1} -row 2 -col 1 diff --git a/rtl/src/bram_tdp.v b/rtl/src/bram_tdp.v new file mode 100644 index 0000000..9537b9c --- /dev/null +++ b/rtl/src/bram_tdp.v @@ -0,0 +1,46 @@ +`timescale 1ns / 1ps +// taken from https://danstrother.com/2010/09/11/inferring-rams-in-fpgas/ +// modified for one read/write-port and one read-only-port, +/// A parameterized, inferable, true dual-port, dual-clock block RAM in Verilog. + +module bram_tdp #( + parameter DATA = 72, + parameter ADDR = 10 +) ( + // Port A + input wire a_clk, + input wire a_rd, + input wire a_wr, + input wire [ADDR-1:0] a_addr, + input wire [DATA-1:0] a_din, + output reg [DATA-1:0] a_dout, + // Port B + input wire b_clk, + input wire [ADDR-1:0] b_addr, + output reg [DATA-1:0] b_dout, + input wire b_rd +); + +// Shared memory + reg [DATA-1:0] mem [(2**ADDR)-1:0]; + + wire a_en = a_rd || a_wr; + +// Port A +always @(posedge a_clk) begin + if(a_en) + begin + if(a_wr) + mem[a_addr] <= a_din; + else if(a_rd) + a_dout <= mem[a_addr]; + end +end + +// Port B +always @(posedge b_clk) begin + if(b_rd) + b_dout <= mem[b_addr]; +end + +endmodule diff --git a/rtl/src/cpuclk.v b/rtl/src/cpuclk.v new file mode 100644 index 0000000..613d85e --- /dev/null +++ b/rtl/src/cpuclk.v @@ -0,0 +1,83 @@ +`timescale 1ns / 1ps + +module cpu_clkgen( + input wire rst, + input wire clk100, + output wire cpuclk, + output wire dram_refclk, + output wire pixclk, + output wire locked + ); + + wire cpuclk_pre, clk_fb, refclk_pre, pixclk_pre; + + MMCME2_BASE #( + .BANDWIDTH("OPTIMIZED"), // Jitter programming (OPTIMIZED, HIGH, LOW) + .CLKFBOUT_MULT_F(10.0), // Multiply value for all CLKOUT (2.000-64.000). + .CLKFBOUT_PHASE(0.0), // Phase offset in degrees of CLKFB (-360.000-360.000). + .CLKIN1_PERIOD(10.0), // Input clock period in ns to ps resolution (i.e. 33.333 is 30 MHz). + // CLKOUT0_DIVIDE - CLKOUT6_DIVIDE: Divide amount for each CLKOUT (1-128) + .CLKOUT0_DIVIDE_F(12.0), // Divide amount for CLKOUT0 (1.000-128.000). + .CLKOUT1_DIVIDE(5), + .CLKOUT2_DIVIDE(40), // 40 = 25MHz pixel clock (should be 25.175MHz per spec) for 640x480 + //.CLKOUT2_DIVIDE(25), // 25 = 40MHz pixel clock for 800x600 + //.CLKOUT2_DIVIDE(15), // 15 = 66.66MHz pixel clock (should be 65.0Mhz per spec) for 1024x768 + .CLKOUT3_DIVIDE(1), + .CLKOUT4_DIVIDE(1), + .CLKOUT5_DIVIDE(1), + .CLKOUT6_DIVIDE(1), + // CLKOUT0_DUTY_CYCLE - CLKOUT6_DUTY_CYCLE: Duty cycle for each CLKOUT (0.01-0.99). + .CLKOUT0_DUTY_CYCLE(0.5), + .CLKOUT1_DUTY_CYCLE(0.5), + .CLKOUT2_DUTY_CYCLE(0.5), + .CLKOUT3_DUTY_CYCLE(0.5), + .CLKOUT4_DUTY_CYCLE(0.5), + .CLKOUT5_DUTY_CYCLE(0.5), + .CLKOUT6_DUTY_CYCLE(0.5), + // CLKOUT0_PHASE - CLKOUT6_PHASE: Phase offset for each CLKOUT (-360.000-360.000). + .CLKOUT0_PHASE(0.0), + .CLKOUT1_PHASE(0.0), + .CLKOUT2_PHASE(0.0), + .CLKOUT3_PHASE(0.0), + .CLKOUT4_PHASE(0.0), + .CLKOUT5_PHASE(0.0), + .CLKOUT6_PHASE(0.0), + .CLKOUT4_CASCADE("FALSE"), // Cascade CLKOUT4 counter with CLKOUT6 (FALSE, TRUE) + .DIVCLK_DIVIDE(1), // Master division value (1-106) + .REF_JITTER1(0.010), // Reference input jitter in UI (0.000-0.999). + .STARTUP_WAIT("FALSE") // Delays DONE until MMCM is locked (FALSE, TRUE) + ) + + MMCME2_BASE_inst ( + /* verilator lint_off PINCONNECTEMPTY */ + // Clock Outputs: 1-bit (each) output: User configurable clock outputs + .CLKOUT0(cpuclk_pre), // 1-bit output: CLKOUT0 + .CLKOUT0B(), // 1-bit output: Inverted CLKOUT0 + .CLKOUT1(refclk_pre), // 1-bit output: CLKOUT1 + .CLKOUT1B(), // 1-bit output: Inverted CLKOUT1 + .CLKOUT2(pixclk_pre), // 1-bit output: CLKOUT2 + .CLKOUT2B(), // 1-bit output: Inverted CLKOUT2 + .CLKOUT3(), // 1-bit output: CLKOUT3 + .CLKOUT3B(), // 1-bit output: Inverted CLKOUT3 + .CLKOUT4(), // 1-bit output: CLKOUT4 + .CLKOUT5(), // 1-bit output: CLKOUT5 + .CLKOUT6(), // 1-bit output: CLKOUT6 + // Feedback Clocks: 1-bit (each) output: Clock feedback ports + .CLKFBOUT(clk_fb), // 1-bit output: Feedback clock + .CLKFBOUTB(), // 1-bit output: Inverted CLKFBOUT + // Status Ports: 1-bit (each) output: MMCM status ports + .LOCKED(locked), // 1-bit output: LOCK + // Clock Inputs: 1-bit (each) input: Clock input + .CLKIN1(clk100), // 1-bit input: Clock + // Control Ports: 1-bit (each) input: MMCM control ports + .PWRDWN(), // 1-bit input: Power-down + /* verilator lint_on PINCONNECTEMPTY */ + .RST(rst), // 1-bit input: Reset + // Feedback Clocks: 1-bit (each) input: Clock feedback ports + .CLKFBIN(clk_fb) // 1-bit input: Feedback clock + ); + + BUFG bufg_cpuclk(.I(cpuclk_pre), .O(cpuclk)); + BUFG bufg_refclk(.I(refclk_pre), .O(dram_refclk)); + BUFG bufg_pixclk(.I(pixclk_pre), .O(pixclk)); +endmodule diff --git a/rtl/src/display_clock.v b/rtl/src/display_clock.v new file mode 100644 index 0000000..898ef7a --- /dev/null +++ b/rtl/src/display_clock.v @@ -0,0 +1,96 @@ +`timescale 1ns / 1ps +`default_nettype none + +// Project F: Display Clocks +// (C)2019 Will Green, Open source hardware released under the MIT License +// Learn more at https://projectf.io + +// Defaults to 25.2 and 126 MHz for 640x480 at 60 Hz + +module display_clock #( + MULT_MASTER=31.5, // master clock multiplier (2.000-64.000) + DIV_MASTER=5, // master clock divider (1-106) + DIV_5X=5.0, // 5x clock divider (1-128) + DIV_1X=25, // 1x clock divider (1-128) + IN_PERIOD=10.0 // period of i_clk in ns (100 MHz = 10.0 ns) + ) + ( + input wire i_clk, // input clock + input wire i_rst, // reset (active high) + output wire o_clk_1x, // pixel clock + output wire o_clk_5x, // 5x clock for 10:1 DDR SerDes + output wire o_locked // clock locked? (active high) + ); + + wire clk_fb; // internal clock feedback + wire clk_1x_pre; + wire clk_5x_pre; + + MMCME2_BASE #( + .BANDWIDTH("OPTIMIZED"), // Jitter programming (OPTIMIZED, HIGH, LOW) + .CLKFBOUT_MULT_F(MULT_MASTER), // Multiply value for all CLKOUT (2.000-64.000). + .CLKFBOUT_PHASE(0.0), // Phase offset in degrees of CLKFB (-360.000-360.000). + .CLKIN1_PERIOD(IN_PERIOD), // Input clock period in ns to ps resolution (i.e. 33.333 is 30 MHz). + // CLKOUT0_DIVIDE - CLKOUT6_DIVIDE: Divide amount for each CLKOUT (1-128) + .CLKOUT0_DIVIDE_F(DIV_5X), // Divide amount for CLKOUT0 (1.000-128.000). + .CLKOUT1_DIVIDE(DIV_1X), + .CLKOUT2_DIVIDE(1), + .CLKOUT3_DIVIDE(1), + .CLKOUT4_DIVIDE(1), + .CLKOUT5_DIVIDE(1), + .CLKOUT6_DIVIDE(1), + // CLKOUT0_DUTY_CYCLE - CLKOUT6_DUTY_CYCLE: Duty cycle for each CLKOUT (0.01-0.99). + .CLKOUT0_DUTY_CYCLE(0.5), + .CLKOUT1_DUTY_CYCLE(0.5), + .CLKOUT2_DUTY_CYCLE(0.5), + .CLKOUT3_DUTY_CYCLE(0.5), + .CLKOUT4_DUTY_CYCLE(0.5), + .CLKOUT5_DUTY_CYCLE(0.5), + .CLKOUT6_DUTY_CYCLE(0.5), + // CLKOUT0_PHASE - CLKOUT6_PHASE: Phase offset for each CLKOUT (-360.000-360.000). + .CLKOUT0_PHASE(0.0), + .CLKOUT1_PHASE(0.0), + .CLKOUT2_PHASE(0.0), + .CLKOUT3_PHASE(0.0), + .CLKOUT4_PHASE(0.0), + .CLKOUT5_PHASE(0.0), + .CLKOUT6_PHASE(0.0), + .CLKOUT4_CASCADE("FALSE"), // Cascade CLKOUT4 counter with CLKOUT6 (FALSE, TRUE) + .DIVCLK_DIVIDE(DIV_MASTER), // Master division value (1-106) + .REF_JITTER1(0.010), // Reference input jitter in UI (0.000-0.999). + .STARTUP_WAIT("FALSE") // Delays DONE until MMCM is locked (FALSE, TRUE) + ) + MMCME2_BASE_inst ( + /* verilator lint_off PINCONNECTEMPTY */ + // Clock Outputs: 1-bit (each) output: User configurable clock outputs + .CLKOUT0(clk_5x_pre), // 1-bit output: CLKOUT0 + .CLKOUT0B(), // 1-bit output: Inverted CLKOUT0 + .CLKOUT1(clk_1x_pre), // 1-bit output: CLKOUT1 + .CLKOUT1B(), // 1-bit output: Inverted CLKOUT1 + .CLKOUT2(), // 1-bit output: CLKOUT2 + .CLKOUT2B(), // 1-bit output: Inverted CLKOUT2 + .CLKOUT3(), // 1-bit output: CLKOUT3 + .CLKOUT3B(), // 1-bit output: Inverted CLKOUT3 + .CLKOUT4(), // 1-bit output: CLKOUT4 + .CLKOUT5(), // 1-bit output: CLKOUT5 + .CLKOUT6(), // 1-bit output: CLKOUT6 + // Feedback Clocks: 1-bit (each) output: Clock feedback ports + .CLKFBOUT(clk_fb), // 1-bit output: Feedback clock + .CLKFBOUTB(), // 1-bit output: Inverted CLKFBOUT + // Status Ports: 1-bit (each) output: MMCM status ports + .LOCKED(o_locked), // 1-bit output: LOCK + // Clock Inputs: 1-bit (each) input: Clock input + .CLKIN1(i_clk), // 1-bit input: Clock + // Control Ports: 1-bit (each) input: MMCM control ports + .PWRDWN(), // 1-bit input: Power-down + /* verilator lint_on PINCONNECTEMPTY */ + .RST(i_rst), // 1-bit input: Reset + // Feedback Clocks: 1-bit (each) input: Clock feedback ports + .CLKFBIN(clk_fb) // 1-bit input: Feedback clock + ); + + // explicitly buffer output clocks + BUFG bufg_clk_pix(.I(clk_1x_pre), .O(o_clk_1x)); + BUFG bufg_clk_pix_5x(.I(clk_5x_pre), .O(o_clk_5x)); + +endmodule \ No newline at end of file diff --git a/rtl/src/dram_bridge.v b/rtl/src/dram_bridge.v new file mode 100644 index 0000000..102a8cf --- /dev/null +++ b/rtl/src/dram_bridge.v @@ -0,0 +1,165 @@ +`timescale 1ns / 1ps + +module dram_bridge #(ADDR_WIDTH = 32, WIDTH = 32) +( + // local bus + input wire [ADDR_WIDTH-1:0] mem_addr, + output wire [WIDTH-1:0] mem_read_data, + input wire [WIDTH-1:0] mem_write_data, + input wire mem_read_enable, + input wire mem_write_enable, + output wire mem_wait, + + input wire rst_n, + input wire dram_front_clk, + input wire dram_refclk, + + // DDR3 SDRAM + inout wire [15:0] ddr3_dq, + inout wire [1:0] ddr3_dqs_n, + inout wire [1:0] ddr3_dqs_p, + + output wire [13:0] ddr3_addr, + output wire [2:0] ddr3_ba, + output wire ddr3_ras_n, + output wire ddr3_cas_n, + output wire ddr3_we_n, + output wire ddr3_reset_n, + output wire [0:0] ddr3_ck_p, + output wire [0:0] ddr3_ck_n, + output wire [0:0] ddr3_cke, + output wire [0:0] ddr3_cs_n, + output wire [1:0] ddr3_dm, + output wire [0:0] ddr3_odt +); + + localparam DRAM_ADDR_WIDTH = 28, DRAM_DATA_WIDTH = 128, DRAM_MASK_WIDTH = 16; + wire [DRAM_ADDR_WIDTH-1:0] app_addr; + wire [2:0] app_cmd; + wire app_en; + wire app_rdy; + wire [DRAM_DATA_WIDTH-1:0] app_rd_data; + wire app_rd_data_end; + wire app_rd_data_valid; + wire [DRAM_DATA_WIDTH-1:0] app_wdf_data; + wire app_wdf_end; + wire [DRAM_MASK_WIDTH-1:0] app_wdf_mask; + wire app_wdf_rdy; + wire app_sr_active; + wire app_ref_ack; + wire app_zq_ack; + wire app_wdf_wren; + wire [11:0] device_temp; + wire ui_clk, ui_rst_sync; + wire init_calib_complete; + + localparam CMD_READ = 3'b1; + localparam CMD_WRITE = 3'b0; + + mig_dram_0 dram0( + // Inouts + .ddr3_dq(ddr3_dq), + .ddr3_dqs_n(ddr3_dqs_n), + .ddr3_dqs_p(ddr3_dqs_p), + // Outputs + .ddr3_addr(ddr3_addr), + .ddr3_ba(ddr3_ba), + .ddr3_ras_n(ddr3_ras_n), + .ddr3_cas_n(ddr3_cas_n), + .ddr3_we_n(ddr3_we_n), + .ddr3_reset_n(ddr3_reset_n), + .ddr3_ck_p(ddr3_ck_p), + .ddr3_ck_n(ddr3_ck_n), + .ddr3_cke(ddr3_cke), + .ddr3_cs_n(ddr3_cs_n), + .ddr3_dm(ddr3_dm), + .ddr3_odt(ddr3_odt), +// Application interface ports + .app_addr (app_addr), + .app_cmd (app_cmd), + .app_en (app_en), + .app_wdf_data (app_wdf_data), + .app_wdf_mask (app_wdf_mask), + .app_wdf_end (app_wdf_end), + .app_wdf_wren (app_wdf_wren), + .app_rd_data (app_rd_data), + .app_rd_data_end (app_rd_data_end), + .app_rd_data_valid (app_rd_data_valid), + .app_rdy (app_rdy), + .app_wdf_rdy (app_wdf_rdy), + .app_sr_req (1'b0), + .app_ref_req (1'b0), + .app_zq_req (1'b0), + .app_sr_active (app_sr_active), + .app_ref_ack (app_ref_ack), + .app_zq_ack (app_zq_ack), + .ui_clk (ui_clk), + .ui_clk_sync_rst (ui_rst_sync), + +// System Clock Ports + .sys_clk_i (dram_front_clk), +// Reference Clock Ports + .clk_ref_i (dram_refclk), + .device_temp (device_temp), + .init_calib_complete (init_calib_complete), + .sys_rst (rst_n) + ); + +// reg [DRAM_DATA_WIDTH-1:0] read_cache; +// reg [ADDR_WIDTH-1:0] cached_addr; +// wire cache_hit = cached_addr == mem_addr; +// wire [DRAM_DATA_WIDTH-1:0] read_data_wrapper = cache_hit ? read_cache : app_rd_data; + + reg [WIDTH-1:0] read_buf; + reg read_inprogress = 0; + + assign app_rd_data_end = 1'b1; + //assign app_wdf_mask = 16'b1111111111111100; + + // addresses on the memory interface are aligned to 16 bytes + // and 28 bits wide (=256MB) + assign app_addr = { mem_addr[DRAM_ADDR_WIDTH:4], 4'b0000 }; + //assign app_addr = { 28'b0 }; + + // select a word from the 128 bits transferred by the dram controller + // according to the lower bits of the address (ignoring bits 1:0) + wire [WIDTH-1:0] read_word; + wire [1:0] word_sel = mem_addr[3:2]; + + assign read_word = word_sel == 3'b11 ? app_rd_data[31:0] : + word_sel == 3'b10 ? app_rd_data[63:32] : + word_sel == 3'b01 ? app_rd_data[95:64] : + app_rd_data[127:96]; + + assign mem_read_data = app_rd_data_valid ? read_word : read_buf; + + // set the write mask according to the lower bits of the address + // (ignoring bit 0) + assign app_wdf_mask = word_sel == 3'b11 ? 16'b1111111111110000 : + word_sel == 3'b10 ? 16'b1111111100001111 : + word_sel == 3'b01 ? 16'b1111000011111111 : + 16'b0000111111111111 ; + + wire write_ready = mem_write_enable & app_wdf_rdy & app_rdy; + assign app_wdf_wren = mem_write_enable & write_ready; + assign app_wdf_end = mem_write_enable & write_ready; + assign app_wdf_data = { {4{mem_write_data}} }; + + assign mem_wait = (mem_read_enable & ~read_inprogress) | + (mem_write_enable & (~app_wdf_rdy | ~app_rdy)) | + (read_inprogress & ~app_rd_data_valid); + + assign app_en = (mem_read_enable & ~read_inprogress) | + (mem_write_enable & write_ready); + assign app_cmd = mem_read_enable ? CMD_READ : CMD_WRITE; + + always @(posedge dram_front_clk) + begin + if(mem_read_enable & ~read_inprogress & app_rdy) + read_inprogress <= 1; + if(read_inprogress & app_rd_data_valid) + read_inprogress <= 0; + if(mem_read_enable & app_rd_data_valid) + read_buf <= mem_read_data; + end +endmodule diff --git a/rtl/src/fifo.v b/rtl/src/fifo.v new file mode 100644 index 0000000..16d9583 --- /dev/null +++ b/rtl/src/fifo.v @@ -0,0 +1,53 @@ +`timescale 1ns / 1ps + +// a simple fifo +module fifo #(parameter DATA_WIDTH = 8, ADDR_WIDTH = 4)( + input wire clk, + input wire reset, + input wire wr_en, + input wire rd_en, + input wire [DATA_WIDTH-1:0] wr_data, + output wire [DATA_WIDTH-1:0] rd_data, + output wire wr_full, + output wire rd_empty + ); + + reg [DATA_WIDTH-1:0] mem [0:2**ADDR_WIDTH-1]; + reg [ADDR_WIDTH:0] head_x = 0; // head and tail have one extra bit + reg [ADDR_WIDTH:0] tail_x = 0; // for detecting overflows + wire [ADDR_WIDTH-1:0] head = head_x[ADDR_WIDTH-1:0]; + wire [ADDR_WIDTH-1:0] tail = tail_x[ADDR_WIDTH-1:0]; + + assign rd_data = mem[tail]; + // the fifo is full when head and tail pointer are the same + // and the extra bits differ (a wraparound occured) + assign wr_full = (head == tail) && (head_x[ADDR_WIDTH] != tail_x[ADDR_WIDTH]); + // the fifo is empty when head and tail pointer are the same + // and the extra bits are the same (no wraparound) + assign rd_empty = (head == tail) && (head_x[ADDR_WIDTH] == tail_x[ADDR_WIDTH]); + + // Writing to FIFO + always @(posedge clk) begin + if (reset) + head_x <= 0; + else if (wr_en) + begin + mem[head] <= wr_data; + // move head, possible wraparound + head_x <= head_x + 1'b1; + end + end + + // Reading from FIFO + always @(posedge clk) + begin + if (reset) + tail_x <= 0; + else if (rd_en) + begin + // rd_data always has current tail data + // move tail, possible wraparound + tail_x <= tail_x + 1'b1; + end + end +endmodule \ No newline at end of file diff --git a/rtl/src/fifo_testbench.v b/rtl/src/fifo_testbench.v new file mode 100644 index 0000000..ccc29ee --- /dev/null +++ b/rtl/src/fifo_testbench.v @@ -0,0 +1,116 @@ +`timescale 1ns / 1ns +`default_nettype none + +module fifo_testbench(); + // Test signals + reg clk = 0; + reg reset = 0; + reg wr_en = 0; + reg rd_en = 0; + reg [7:0] wr_data = 0; + wire [7:0] rd_data; + wire wr_full; + wire rd_empty; + + parameter CLOCK_NS = 10; + + // Unit Under Test + fifo #( + .DATA_WIDTH(8), + .ADDR_WIDTH(4) + ) UUT ( + .clk(clk), + .reset(reset), + .wr_en(wr_en), + .rd_en(rd_en), + .rd_data(rd_data), + .wr_data(wr_data), + .wr_full(wr_full), + .rd_empty(rd_empty) + ); + + // testbench clock + always + #(CLOCK_NS/2) clk <= ~clk; + + initial + begin + // issue reset + reset = 1'b1; + #10 + reset = 1'b0; + #10 + + // Write two bytes + wr_data <= 8'hAB; + wr_en <= 1'b1; + #10; + wr_data <= 8'hCD; + wr_en <= 1'b1; + #10; + wr_en <= 1'b0; + #10 + + // read fifo tail + if (rd_data == 8'hAB) + $display("Pass - Byte 1"); + else + $display("Failed - Byte 2"); + + // read/remove byte from tail + rd_en <= 1'b1; + #10 + // check next byte + if (rd_data == 8'hCD) + $display("Pass - Byte 2"); + else + $display("Failed - Byte 2"); + + // remove 2nd byte + rd_en <= 1'b1; + #10 + + rd_en <= 1'b0; + #10 + + // Write until full + rd_en <= 1'b0; + wr_en <= 1'b0; + + for (integer i = 0; i < 16; i = i + 1) begin + wr_data <= i; + wr_en <= 1'b1; + #10; + end + wr_en <= 1'b0; + + if (wr_full) + $display("Pass - Fifo full"); + else + $display("Failed - Fifo full"); + + + // read until empty + rd_en <= 1'b0; + wr_en <= 1'b0; + + for (integer i = 0; i < 16; i = i + 1) begin + rd_en <= 1'b1; + #10; + end + rd_en <= 1'b0; + + if (rd_empty) + $display("Pass - Fifo empty"); + else + $display("Failed - Fifo empty"); + $finish(); + end + + initial + begin + // Required to dump signals + $dumpfile("fifo_tb_dump.vcd"); + $dumpvars(0); + end +endmodule diff --git a/rtl/src/irqctrl.v b/rtl/src/irqctrl.v new file mode 100644 index 0000000..1a079bf --- /dev/null +++ b/rtl/src/irqctrl.v @@ -0,0 +1,73 @@ +`timescale 1ns / 1ps + +module irqctrl #(IRQ_LINES = 2, IRQ_DELAY_WIDTH = 4) ( + input wire clk, + input wire [IRQ_LINES-1:0] irq_in, + input wire cs, + input wire wr_en, + input wire irq_wr_seten, + output wire [IRQ_LINES-1:0] rd_data, + output wire irq_out + ); + + reg [IRQ_LINES-1:0] irq_status; // a 1 bit here means we have seen an interrupt on that line + reg [IRQ_LINES-1:0] irq_mask; // a bit in irq_status is only set if the corresponding bit in irq_mask is not set + // irq_mask is set from irq_status when an interrupt occurs (ie irq_out is set) + + reg irq_enabled; // globally enable/disable irq_out + reg [IRQ_DELAY_WIDTH-1:0] irq_delay; // counter to delay irq_out for a few cycles + reg irq_delaying; // delay is active + + wire irq_pending = (irq_status != 0); + + assign rd_data = irq_mask; + assign irq_out = irq_enabled && irq_pending && !irq_delaying; + + // irq_status and irq_pending flags + always @(posedge clk) + begin + if(irq_out) // when an interrupt is being signaled to the cpu, + irq_status <= 0; // clear irq status, status will be copied to irq_mask (see below) + else + if(irq_in != 0) + irq_status <= irq_status | (irq_in & ~irq_mask); // add active irq to irq_status + end + + // irq mask + always @(posedge clk) + begin + if (cs && wr_en && irq_wr_seten) // when enabling interrupts, clear mask + irq_mask <= 0; + else + if(irq_out) // when signalling an interrupt, set mask from status + irq_mask <= irq_status; + end + + // manage irq_enabled and irq_delay/irq_delaying + always @(posedge clk) + begin + if(cs && wr_en) // when writing to control register + begin + if(irq_wr_seten) // if wr_seten flag is set, enable interrupts and start delay + begin + irq_enabled <= 1; + irq_delaying <= 1; + irq_delay <= 1; + end + else + irq_enabled <= 0; // else disable interrupts + end + else if(irq_out) irq_enabled <= 0; // after sending interrupt to cpu, disable further interrupts + + if(irq_delaying) // the delay gives the CPU a chance to return from an interrupt handler + begin // if an interrupt is triggered again right after re-enabling interrupts + if(irq_delay==0) + begin + irq_delay <= 1; + irq_delaying <= 0; + end + else + irq_delay <= irq_delay + 1; + end + end + endmodule diff --git a/rtl/src/mem.v b/rtl/src/mem.v new file mode 100644 index 0000000..954443a --- /dev/null +++ b/rtl/src/mem.v @@ -0,0 +1,161 @@ +`timescale 1ns / 1ps +////////////////////////////////////////////////////////////////////////////////// +// Company: +// Engineer: +// +// Create Date: 05.01.2021 21:53:41 +// Design Name: +// Module Name: mem +// Project Name: +// Target Devices: +// Tool Versions: +// Description: +// +// Dependencies: +// +// Revision: +// Revision 0.01 - File Created +// Additional Comments: +// +////////////////////////////////////////////////////////////////////////////////// + +// 32 bit wide rom with byte addressing (address bits 1-0 are ignored) +module rom32 #(parameter ADDR_WIDTH = 11, DATA_WIDTH = 32) +( + input wire clk, + input wire [ADDR_WIDTH-1:0] addr, + output reg [DATA_WIDTH-1:0] data_out, + input wire read_enable + ); + + wire [ADDR_WIDTH-2:0] internal_addr = addr[ADDR_WIDTH-1:2]; // -> ignore bit 0 + reg [DATA_WIDTH-1:0] rom [0:(2**(ADDR_WIDTH-2))-1]; + + initial begin + $readmemb("C:\\Users\\sebastian\\develop\\fpga\\vdumbcpu\\rom.mem", rom); + end + + always @(posedge clk) data_out <= rom[internal_addr]; + +endmodule + +module ram32 #(parameter ADDR_WIDTH = 16, DATA_WIDTH = 32) + +( + input wire clk, + input wire [ADDR_WIDTH-1:0] addr, + output reg [DATA_WIDTH-1:0] data_out, + input wire read_enable, + input wire [DATA_WIDTH-1:0] data_in, + input wire write_enable + ); + + reg [DATA_WIDTH-1:0] ram [0:(2**(ADDR_WIDTH-2))-1]; // 32bit words with byte addressing + wire [ADDR_WIDTH-2:0] internal_addr = addr[ADDR_WIDTH-1:2]; // -> ignore bit 1-0 + + always @(posedge clk) + begin + if(read_enable) + data_out <= ram[internal_addr]; + if(write_enable) + ram[internal_addr] <= data_in; + end +endmodule + +module mem #(parameter ADDR_WIDTH = 32, + parameter DATA_WIDTH = 32) +( + input wire clk, rst_n, + input wire [ADDR_WIDTH-1:0] addr, + output wire [DATA_WIDTH-1:0] data_out, + input wire read_enable, + input wire [DATA_WIDTH-1:0] data_in, + input wire write_enable, + output wire io_enable, + input wire [DATA_WIDTH-1:0] io_rd_data, + output wire mem_wait, + + output wire [ADDR_WIDTH-1:0] dram_addr, + input wire [DATA_WIDTH-1:0] dram_read_data, + output wire [DATA_WIDTH-1:0] dram_write_data, + output wire dram_read_enable, + output wire dram_write_enable, + input wire dram_wait + ); + + wire [DATA_WIDTH-1:0] ram_out, rom_out, dram_out; + + // address map: + // ROM $0000 - $07FF 2K + // IO $0800 - $0FFF 2K + // RAM1 $1000 - $FFFF 60K + // RAM2 $10000 - $FFFFFFFF ~4GB + + wire ram_cs = addr[ADDR_WIDTH-1:12] != { {(ADDR_WIDTH-12){1'b0}}}; + wire ram1_cs = ram_cs && (addr[ADDR_WIDTH-1:16] == { {(ADDR_WIDTH-16){1'b0}}}); + wire ram2_cs = ram_cs && !ram1_cs; + wire rom_cs = !ram_cs && addr[11] == 1'b0; + wire io_cs = !ram_cs && addr[11] == 1'b1; + + assign io_enable = io_cs; + + wire ram_read = ram1_cs && read_enable; + wire ram_write = ram1_cs && write_enable; + wire rom_read = rom_cs && read_enable; + + reg [DATA_WIDTH-1:0] data_buf; + + localparam SEL_RAM1 = 0; + localparam SEL_RAM2 = 1; + localparam SEL_ROM = 2; + localparam SEL_IO = 3; + localparam SEL_ERR = 4; + + reg [1:0] out_sel; + + // test + reg [1:0] wait_state; + + ram32 #(.ADDR_WIDTH(16)) ram0 // 64KB RAM + ( + .clk(clk), + .addr(addr[15:0]), + .data_out(ram_out), + .read_enable(ram_read), + .data_in(data_in), + .write_enable(ram_write) + ); + + rom32 #(.ADDR_WIDTH(11)) rom0 // 2KB ROM + ( + .clk(clk), + .addr(addr[10:0]), + .data_out(rom_out), + .read_enable(rom_read) + ); + + assign dram_out = dram_read_data; + assign dram_addr = addr; + assign dram_write_data = data_in; + assign dram_read_enable = ram2_cs & read_enable; + assign dram_write_enable = ram2_cs & write_enable; + + assign data_out = (out_sel == SEL_RAM1 ) ? ram_out : + (out_sel == SEL_RAM2 ) ? dram_out : + (out_sel == SEL_ROM ) ? rom_out : + (out_sel == SEL_IO ) ? io_rd_data : + data_buf; + + assign mem_wait = ram2_cs && dram_wait; + + always @(posedge clk) + begin + data_buf <= data_out; + if(read_enable) out_sel <= + ram1_cs ? SEL_RAM1 : + ram2_cs ? SEL_RAM2: + rom_cs ? SEL_ROM : + io_cs ? SEL_IO : + SEL_ERR; + end +endmodule diff --git a/rtl/src/palette.v b/rtl/src/palette.v new file mode 100644 index 0000000..d076453 --- /dev/null +++ b/rtl/src/palette.v @@ -0,0 +1,28 @@ +`timescale 1ns / 1ps +// taken from https://danstrother.com/2010/09/11/inferring-rams-in-fpgas/ +// modified for one read/write-port and one read-only-port, +/// A parameterized, inferable, true dual-port, dual-clock block RAM in Verilog. + +module palette #( + parameter SLOTS_WIDTH = 4, COLOR_WIDTH = 12 +) ( + input wire wr_clk, + input wire rd_clk, + input wire wr_en, + input wire [SLOTS_WIDTH-1:0] wr_slot, + input wire [COLOR_WIDTH-1:0] wr_data, + input wire [SLOTS_WIDTH-1:0] rd_slot, + output wire [COLOR_WIDTH-1:0] rd_data +); + +// Shared memory + reg [COLOR_WIDTH-1:0] colors [(2**SLOTS_WIDTH)-1:0]; + + assign rd_data = colors[rd_slot]; + + always @(posedge wr_clk) begin + if(wr_en) colors[wr_slot] <= wr_data; + end + +endmodule + diff --git a/rtl/src/sdspi.v b/rtl/src/sdspi.v new file mode 100644 index 0000000..7141288 --- /dev/null +++ b/rtl/src/sdspi.v @@ -0,0 +1,372 @@ +`timescale 1ns / 1ps + + +// Every spi_clk_div cpu clock cycles the spi clock line is inverted. +// So a spi clock cycle is 2*spi_clk_div cpu clock cycles. +// spi_clk_count counts the cpu cycles from spi_clk_div down to zero. +// The resulting spi clock frequency is: +// (cpu clock freq) / ((sclk_count + 1) * 2) +// So for a 83.33 MHz cpu clock, we get +// spi_clk_div = 10: 83.333 / 22 = 3.788 MHz +// spi_clk_div = 124: 83.333 / 250 = 333.33 KHz + + +module sdspi( + input wire clk, // bus clock + input wire reset, + + input wire[7:0] tx_data, // data to transmit + output wire[7:0] rx_data, // data received + output wire tx_ready, // ready to write a data byte + output wire tx_empty, // transmitter fifo is empty + output wire rx_avail, // a byte has been received + output wire rx_ovr, // receiver overrun + input wire tx_write, // write strobe + input wire rx_read, // read strobe (clears rx_ovr) + + output wire card_detect, // true is card is present + output wire card_changed, // card_detect signal has changed + output wire card_busy, // card is busy (MISO/DO is 0) + + input wire ctrl_write, // set the following flags + input wire rx_filter_en, // set to discard received $FF bytes + input wire txrx_en, // enable transmitter and receiver + input wire spiclk_f_en, // enable spi clock without cs + input wire spiclk_div_wr, // set clock divider via tx_data + + // PMOD connections + output wire sd_cs_n, + output reg sd_mosi, + input wire sd_miso, + output wire sd_sck, + input wire sd_cd + ); + + localparam CLKPHASE_0A = 2'b00; + localparam CLKPHASE_0B = 2'b01; + localparam CLKPHASE_1A = 2'b10; + localparam CLKPHASE_1B = 2'b11; + reg [1:0] clk_phase; + + reg xcvr_on; // if turned off, the rest of the current byte + // will still transmitted, and until then "running" + // will be 1 + (* KEEP *) + reg running; // transmitting/receiving a byte (maybe a dummy byte) + + (* KEEP *) reg [3:0] xcvr_bitcount; // number of bits left of the current byte + + reg [7:0] tx_shifter; + wire tx_fifo_wr_en; + reg tx_fifo_rd_en; + wire tx_fifo_full; + wire tx_fifo_empty; + wire [7:0] tx_fifo_out; + + reg [7:0] rx_shifter; + reg rx_filter; + reg rx_fifo_wr_en; + wire rx_fifo_rd_en; + wire rx_fifo_full; + wire rx_fifo_empty; + wire [7:0] rx_fifo_out; + + reg rx_bit_recvd; // this flag signals a received bit + + reg rx_overrun; // byte received when rx fifo is full + + reg c_changed; + reg c_cs; + + reg spi_clk; // the spi clock signal + reg spi_clk_on; // enable clock, either via init mode or by xcvr_on + reg spi_clk_f_on; // init clock mode, i.e. start clock but no tx/rx + reg [6:0] spi_clk_count; // counting cpu clock ticks + reg [6:0] spi_clk_div; // tick counter for spi clock phases + wire spi_clk_count_z = (spi_clk_count == 7'b0); + reg hphase_start; // start of a spi clock half-phase + + assign tx_ready = !tx_fifo_full; + assign tx_empty = tx_fifo_empty; + assign rx_avail = !rx_fifo_empty; + assign rx_ovr = rx_overrun; + assign rx_data = rx_fifo_out; + + assign card_busy = (sd_miso == 0); + assign card_changed = c_changed; + + assign sd_sck = spi_clk; + assign sd_cs_n = ~c_cs; + + assign card_detect = sd_cd; + + fifo #(.ADDR_WIDTH(4)) tx_fifo(clk, reset, + tx_fifo_wr_en, tx_fifo_rd_en, + tx_data, tx_fifo_out, + tx_fifo_full, + tx_fifo_empty + ); + + fifo #(.ADDR_WIDTH(8)) rx_fifo(clk, reset, + rx_fifo_wr_en, rx_fifo_rd_en, + rx_shifter, rx_fifo_out, + rx_fifo_full, + rx_fifo_empty + ); + + // spi clock + always @(posedge clk) + begin + if(reset) + begin + spi_clk <= 1; // CLK is high when inactive + spi_clk_on <= 0; + spi_clk_count <= 0; + end + else if(spi_clk_on) + begin + + // set spi_clk at start of every half-phase + if(hphase_start) + case(clk_phase) + CLKPHASE_0A: spi_clk <= 1'b0; + CLKPHASE_0B: spi_clk <= 1'b0; + CLKPHASE_1A: spi_clk <= 1'b1; + CLKPHASE_1B: spi_clk <= 1'b1; + endcase + + if(spi_clk_count_z) + begin + spi_clk_count <= spi_clk_div; + clk_phase <= clk_phase + 2'b1; + end + else + spi_clk_count <= spi_clk_count - 7'd1; + end + + // start the clock if needed + if( (spi_clk_on == 0) && (running || spi_clk_f_on)) + begin + spi_clk_on <= 1; + spi_clk_count <= spi_clk_div; + clk_phase <= CLKPHASE_1A; + end + + // turn off the clock if transceiver not running + // and the force-clock-on flag is not set + if( (spi_clk_on == 1) && (!running && !spi_clk_f_on)) + begin + spi_clk_on <= 0; + spi_clk <= 1'b1; + end + end + + // half-phase-start flag trails spi_clk_count_z by one tick + always @(posedge clk) + begin + if(reset) + hphase_start <= 0; + else + hphase_start <= spi_clk_on && spi_clk_count_z; + end + + // handle the force clock enable flag + always @(posedge clk) + begin + if (reset) + spi_clk_f_on <= 0; + else + if (ctrl_write) + spi_clk_f_on <= spiclk_f_en; + end + + // clock divider + always @(posedge clk) + begin + if (spiclk_div_wr) spi_clk_div <= tx_data[6:0]; + end + + // card_changed flag + always @(posedge clk) + begin + if(sd_cd) + c_changed <= 1; + else if(ctrl_write || reset) + c_changed <= 0; + end + + // cs signal + always @(posedge clk) + begin + if(hphase_start && clk_phase == CLKPHASE_0A || !running) + c_cs <= running; + end + + // transmitter + always @(posedge clk) + begin + if(reset) + begin + // ???? we start the bitcount at 1 because we start + // at the second clock phase where the bitcount + // is decremented and the next byte gets loaded + xcvr_bitcount <= 0; + + tx_shifter <= 8'b1; + xcvr_on <= 0; + sd_mosi <= 1; + tx_fifo_rd_en <= 0; + end + else + begin + // handle a control write to disable the transceiver + if(ctrl_write && !txrx_en && xcvr_on) + xcvr_on <= 0; + // a byte might still be in transit, so + // we do not disable the transceiver + // immediately (see "handle running status" below) + else + // handle control write to enable the transceiver + if(ctrl_write && txrx_en && !running) + begin + xcvr_on <= 1; + xcvr_bitcount <= 0; + // next clock phase must be 1B when starting the transceiver, + // so that the first byte is loaded into the shifter then + tx_shifter <= 8'b11111111; + // in case the transceiver is enabled, but no data is in the fifo, + // initialize the shifter with $FF + end + else + // handle clock phases + if (running) + begin + if(hphase_start) + case(clk_phase) + // set mosi signal at start of clock pulse + CLKPHASE_0A: sd_mosi <= tx_shifter[7]; + CLKPHASE_0B: ; + CLKPHASE_1A: begin // shift at rising clock + tx_shifter <= tx_shifter << 1; + xcvr_bitcount <= xcvr_bitcount - 1; + end + CLKPHASE_1B: begin // in the middle of the high clock pulse, + // fetch the next byte if there are no bits + // left in the shift register + if (xcvr_bitcount == 0) + begin + if(!tx_fifo_empty) + begin + tx_shifter <= tx_fifo_out; + tx_fifo_rd_en <= 1; + end + else + tx_shifter <= 8'b11111111; + xcvr_bitcount <= 8; + end + else + tx_fifo_rd_en <= 0; + end + endcase + else + tx_fifo_rd_en <= 0; + end + end + end + + // handle data write + assign tx_fifo_wr_en = tx_write && !tx_fifo_full; + + // Enable fifo read signal if fifo is not empty. + // The data at the fifo tail is always available at + // rx_data, the read signal just moves the tail pointer + // forward. + assign rx_fifo_rd_en = rx_read && !rx_fifo_empty; + + // receiver + always @(posedge clk) + begin + if(reset) + begin + rx_bit_recvd <= 0; + rx_shifter <= 8'b11111111; + rx_fifo_wr_en <= 0; + rx_filter <= 0; + rx_overrun <= 0; + end + else + begin + // handle a control write + if(ctrl_write) + begin + rx_filter <= rx_filter_en; + rx_overrun <= 0; + if(txrx_en && !running) + rx_shifter <= 8'b0; + end + + if (running && hphase_start) + case(clk_phase) + CLKPHASE_0A: ; + CLKPHASE_0B: ; + CLKPHASE_1A: ; + CLKPHASE_1B: begin // in the middle of the high clock pulse, + // sample MISO and put into shift register + // and shift at the same time + rx_shifter <= { rx_shifter[6:0],sd_miso}; + rx_bit_recvd <= 1; + end + endcase + + if (rx_bit_recvd && !sd_cs_n && clk_phase == CLKPHASE_1B) + begin + rx_bit_recvd <= 0; + + // if a complete byte was received, bitcount will be + // 8 because the transmitter has already loaded the next byte + // at this half-phase + if (xcvr_bitcount == 8) + begin + // discard $FF bytes if filter is enabled + if(!rx_filter || rx_shifter != 8'b11111111) + begin + if(rx_fifo_full) // discard received byte if fifo is full + rx_overrun <= 1; // and set overrun flag + else + rx_fifo_wr_en <= 1; // otherwise, enable fifo write strobe, + // fifo will take data from rx_shifter + end + + // turn off filter if a byte != $FF was received + if (rx_filter && rx_shifter != 8'b11111111) + rx_filter <= 0; + end + end + else + rx_fifo_wr_en <= 0; + + end + end + + // handle running status + // (especially keep transmitter running when there are still bits left to be + // transmitted) + always@(posedge clk) + begin + if (reset) + running <= 0; + else + begin + // if we want to turn the transceiver on, set running flag + if (!running && xcvr_on) + running <= 1; + + // when running and a byte has been transmitted, + // check if we should turn the transceiver off + if (running && hphase_start && xcvr_bitcount==0) + if(clk_phase == CLKPHASE_1B) + if (!xcvr_on) + running <= 0; + end + end +endmodule diff --git a/rtl/src/sdspi_testbench.v b/rtl/src/sdspi_testbench.v new file mode 100644 index 0000000..a4113fb --- /dev/null +++ b/rtl/src/sdspi_testbench.v @@ -0,0 +1,199 @@ +`timescale 1ns / 1ns +`default_nettype none + +module sdspi_testbench(); + parameter CLOCK_NS = 10; + integer i,j; + + reg[7:0] rx_testdata[0:3]; + reg[7:0] read_data; + + // Test signals + reg clk = 0; + reg reset = 0; + + reg[7:0] tx_data = 0; + wire[7:0] rx_data; + wire tx_ready; + wire tx_empty; + wire rx_avail; + wire rx_ovr; + reg tx_write = 0; + reg rx_read = 0; + + wire card_detect; + wire card_changed; + wire card_busy; + + reg ctrl_write = 0; + reg rx_filter_en = 0; + reg txrx_en = 0; + reg spiclk_f_en = 0; + reg spiclk_div_wr = 0; + + // PMOD connections + wire sd_cs_n; + wire sd_mosi; + reg sd_miso = 1; + wire sd_sck; + reg sd_cd = 1; + + // Unit Under Test + sdspi UUT ( + .clk(clk), + .reset(reset), + .tx_data(tx_data), + .rx_data(rx_data), + .tx_ready(tx_ready), + .tx_empty(tx_empty), + .rx_avail(rx_avail), + .rx_ovr(rx_ovr), + .tx_write(tx_write), + .rx_read(rx_read), + .card_detect(card_detect), + .card_changed(card_changed), + .card_busy(card_busy), + .ctrl_write(ctrl_write), + .rx_filter_en(rx_filter_en), + .txrx_en(txrx_en), + .spiclk_f_en(spiclk_f_en), + .spiclk_div_wr(spiclk_div_wr), + .sd_cs_n(sd_cs_n), + .sd_mosi(sd_mosi), + .sd_miso(sd_miso), + .sd_sck(sd_sck), + .sd_cd(sd_cd) + ); + + // testbench clock + always + #(CLOCK_NS/2) clk <= ~clk; + + initial + begin + rx_testdata[0] <= 'hFF; + rx_testdata[1] <= 'hFF; + rx_testdata[2] <= 'hCA; + rx_testdata[3] <= 'hFE; + + // issue reset + reset = 1'b1; + #10 + reset = 1'b0; + #10 + + // set clock divider + tx_data <= 3; + spiclk_div_wr <= 1'b1; + #10 + spiclk_div_wr <= 1'b0; + #10 + + // Card initialization phase, + // cycle the clock at least 74 times + // while cs is off and mosi is high . + // we do 32 cycles + spiclk_f_en <= 1'b1; + ctrl_write <= 1'b1; + #10 + spiclk_f_en <= 1'b0; + ctrl_write <= 1'b0; + #10 + for (i=0; i<32*16; i = i + 1) + #10; + spiclk_f_en <= 1'b0; + ctrl_write <= 1'b1; + #10 + ctrl_write <= 1'b0; + #10 + for (i=0; i<32*16; i = i + 1) + #10; + + // Write two bytes + tx_data <= 8'hAB; + tx_write <= 1'b1; + #10; + tx_data <= 8'hCD; + tx_write <= 1'b1; + #10; + tx_write <= 1'b0; + #10 + + // start transceiver, enable rx_filter + txrx_en <= 1'b1; + rx_filter_en <= 1'b1; + ctrl_write <= 1'b1; + #10 + txrx_en <= 1'b0; + rx_filter_en <= 1'b0; + ctrl_write <= 1'b0; + + for (i = 0; i < 2048; i = i + 1) + begin + if (!sd_cs_n && (i % 16)==15) sd_miso <= rx_testdata[(i/(16*8)) % 4][7 - (i/16 % 8)]; + #10; + end + tx_write <= 1'b0; + #10 + + // read from rx fifo + read_data <= rx_data; + #10 + $display("read data 1: %02h", read_data); + + + // strobe rx_read to go to next byte + rx_read <= 1'b1; + #10 // one cycle to transfer the data + rx_read <= 1'b0; + #10 // we need this extra cycle for the fifo tail to move + + read_data <= rx_data; + #10 + $display("read data 2: %02h", read_data); + + // strobe rx_read to go to next byte + rx_read <= 1'b1; + #10 + rx_read <= 1'b0; + #10 // we need this extra cycle for the fifo tail to move + + read_data <= rx_data; + #10 + $display("read data 3: %02h", read_data); + + + // set flag to turn transceiver off + txrx_en <= 1'b0; + ctrl_write <= 1'b1; + #10 + ctrl_write <= 1'b0; + #10; + + // wait for the transceiver to actually turn off + for (i=0; i<32*16; i = i + 1) + #10; + + #10 + // clear rx fifo + for(i=0; i<14; i = i + 1) + begin + $display("clear fifo data %02h", rx_data); + rx_read <= 1'b1; + #10 + rx_read <= 1'b0; + #10 + #10 + #10; // simulate the four cycles of an instruction + end + + $finish(); + end + + initial + begin + // Required to dump signals + $dumpfile("sdspi_tb_dump.vcd"); + $dumpvars(0); + end +endmodule diff --git a/rtl/src/stack.v b/rtl/src/stack.v new file mode 100644 index 0000000..965c070 --- /dev/null +++ b/rtl/src/stack.v @@ -0,0 +1,42 @@ +`timescale 1ns / 1ps +////////////////////////////////////////////////////////////////////////////////// +// Company: +// Engineer: +// +// Create Date: 17.01.2021 20:59:29 +// Design Name: +// Module Name: stack +// Project Name: +// Target Devices: +// Tool Versions: +// Description: +// +// Dependencies: +// +// Revision: +// Revision 0.01 - File Created +// Additional Comments: +// +////////////////////////////////////////////////////////////////////////////////// + + +module stack + #(parameter ADDR_WIDTH=4, DATA_WIDTH=16) + ( + input wire clk, + input wire [ADDR_WIDTH-1:0] rd_addr, + input wire [ADDR_WIDTH-1:0] wr_addr, + input wire wr_enable, + output wire [DATA_WIDTH-1:0] rd_data, + input wire [DATA_WIDTH-1:0] wr_data + ); + + reg [DATA_WIDTH-1:0] stack[0:2**ADDR_WIDTH-1]; + + always @(posedge clk) + begin + if(wr_enable) stack[wr_addr] <= wr_data; + end + + assign rd_data = stack[rd_addr]; +endmodule diff --git a/rtl/src/stackcpu.v b/rtl/src/stackcpu.v new file mode 100644 index 0000000..c65ae4e --- /dev/null +++ b/rtl/src/stackcpu.v @@ -0,0 +1,427 @@ +`timescale 1ns / 1ps +////////////////////////////////////////////////////////////////////////////////// + +module stackcpu #(parameter ADDR_WIDTH = 32, WIDTH = 32, + WORDSIZE = 4, WORDSIZE_SHIFT = 2) ( + input wire clk, + input wire rst, + + input wire irq, + + output reg [ADDR_WIDTH-1:0] addr, + input wire [WIDTH-1:0] data_in, + output wire read_enable, + output wire [WIDTH-1:0] data_out, + output wire write_enable, + input wire mem_wait, + + output wire led1, + output wire led2, + output wire led3, + + output wire [WIDTH-1:0] debug_out1, + output wire [WIDTH-1:0] debug_out2, + output wire [WIDTH-1:0] debug_out3, + output wire [WIDTH-1:0] debug_out4, + output wire [WIDTH-1:0] debug_out5, + output wire [WIDTH-1:0] debug_out6 + ); + + localparam EVAL_STACK_INDEX_WIDTH = 6; + + wire reset = !rst; + + (* KEEP *) reg [1:0] seq_state; + localparam FETCH = 2'b00; localparam DECODE = 2'b01; localparam EXEC = 2'b10; localparam MEM = 2'b11; + + (* KEEP*) reg [WIDTH-1:0] X, nX; + wire [WIDTH-1:0] Y; + (* KEEP *) reg [WIDTH-1:0] PC, nPC; + reg [WIDTH-1:0] RP, nRP; + reg [WIDTH-1:0] FP, BP; + reg [WIDTH-1:0] IV,IR; + + wire [WIDTH-1:0] pc_next_ins = PC + 2; + + reg [EVAL_STACK_INDEX_WIDTH-1:0] ESP, nESP; + reg stack_write; + + reg irq_pending; + + // eval stack + stack #(.ADDR_WIDTH(EVAL_STACK_INDEX_WIDTH), .DATA_WIDTH(WIDTH)) estack ( + .clk(clk), + .rd_addr(ESP), + .wr_addr(nESP), + .wr_enable(stack_write), + .rd_data(Y), + .wr_data(X) + ); + + reg [15:0] ins; + + wire [WIDTH-1:0] operand; + + // decoded instructions + wire ins_loadrel; + wire ins_load; + wire ins_loadc; + wire ins_store; + wire ins_aluop; + wire ins_ext; + wire ins_xfer; + wire ins_branch; + wire ins_cbranch; + + // decoded extended instructions + wire ins_mem, ins_loadi, ins_storei; + wire ins_fpadj; + wire ins_reg, ins_loadreg, ins_storereg; + wire ins_reg_fp, ins_reg_bp, ins_reg_rp; + wire ins_reg_iv, ins_reg_ir; + wire ins_reg_esp; + wire loadstore_base; + wire cbranch_n; + + wire xfer_x2p, xfer_r2p, xfer_p2r; + wire [1:0] xfer_rs; + + wire [3:0] aluop; + wire [1:0] aluop_sd; + wire aluop_x2y, aluop_ext; + + wire cmp_i, cmp_e, cmp_l; + + wire mem_read; + wire mem_write; + + wire x_is_zero; + // wire [WIDTH-1:0] y_plus_operand = Y + operand; + + wire x_equals_y = X == Y; + wire y_lessthan_x = $signed(Y) < $signed(X); + wire yx_unsigned_less = Y < X; + + reg [WIDTH-1:0] mem_write_data; + + wire mem_read_enable, mem_write_enable; + + assign read_enable = mem_read_enable; + assign data_out = mem_write_data; + assign write_enable = mem_write_enable; + + // debug output ------------------------------------------------------------------------------------ + assign led1 = reset; + assign led2 = ins_loadc; + assign led3 = ins_branch; +// assign debug_out1 = { mem_read_enable, mem_write_enable, x_is_zero, +// ins_branch, ins_aluop, y_lessthan_x, x_equals_y, {7{1'b0}}, seq_state}; +// assign debug_out2 = data_in; +// assign debug_out3 = nX; +// assign debug_out4 = nPC; +// assign debug_out5 = ins; +// assign debug_out6 = IV; + //-------------------------------------------------------------------------------------------------- + + // instruction decoding + assign ins_branch = (ins[15:13] == 3'b000); + assign ins_aluop = (ins[15:13] == 3'b001); + assign ins_store = (ins[15:13] == 3'b010); + assign ins_xfer = (ins[15:13] == 3'b011); + assign ins_load = (ins[15:13] == 3'b100); + assign ins_cbranch = (ins[15:13] == 3'b101); + assign ins_loadc = (ins[15:13] == 3'b110); + assign ins_ext = (ins[15:13] == 3'b111); + + // sub-decode LOAD/STORE + assign loadstore_base = ins[0]; + + // sub-decode CBRANCH + assign cbranch_n = ins[0]; + + // sub-decode XFER + assign xfer_x2p = ins[0]; + assign xfer_r2p = ins[7]; + assign xfer_p2r = ins[6]; + assign xfer_rs = ins[9:8]; + + // sub-decode OP + assign aluop = ins[12:9]; + assign aluop_x2y = ins[6]; + assign aluop_sd = ins[5:4]; + assign aluop_ext = ins[7]; + + // sub-decode OP.CMP + assign cmp_i = ins[2]; + assign cmp_e = ins[1]; + assign cmp_l = ins[0]; + + assign x_is_zero = X == {WIDTH{1'b0}}; + + // decode extended instructions + assign ins_reg = (ins_ext && ins[12:10] == 3'b000); + assign ins_mem = (ins_ext && ins[12:10] == 3'b001); + assign ins_loadi = (ins_mem && ins[9] == 1'b0); + assign ins_storei = (ins_mem && ins[9] == 1'b1); + assign ins_fpadj = (ins_ext && ins[12:10] == 3'b011); + assign ins_loadrel= (ins_ext && ins[12:10] == 3'b101); + + // sub-decode LOADREG/STOREREG + assign ins_loadreg = (ins_reg && ins[9] == 1'b0); + assign ins_storereg = (ins_reg && ins[9] == 1'b1); + assign ins_reg_fp = (ins_reg && ins[3:0] == 4'b0000); + assign ins_reg_bp = (ins_reg && ins[3:0] == 4'b0001); + assign ins_reg_rp = (ins_reg && ins[3:0] == 4'b0010); + assign ins_reg_iv = (ins_reg && ins[3:0] == 4'b0011); + assign ins_reg_ir = (ins_reg && ins[3:0] == 4'b0100); + assign ins_reg_esp = (ins_reg && ins[3:0] == 4'b0101); + + assign mem_read = ins_loadi || ins_load || ins_loadrel || (ins_xfer && xfer_r2p); + assign mem_write = ins_storei || ins_store || (ins_xfer && xfer_p2r); + + assign mem_read_enable = (seq_state == FETCH) || (seq_state == EXEC && mem_read); + assign mem_write_enable = (seq_state == MEM && mem_write); + + initial + begin + PC <= 0; nPC <= 0; seq_state <= MEM; + ESP <= -1; nESP <= -1; + addr <= 0; + FP <= 0; BP <= 0; RP <= 0; nRP <= 0; + IV <= 0; IR <= 0; + irq_pending <= 0; + end + + // instruction sequencer + always @(posedge clk) + begin + if(reset) + seq_state <= MEM; + else if(mem_wait == 1'b0) + case(seq_state) + FETCH: seq_state <= DECODE; + DECODE: seq_state <= EXEC; + EXEC: seq_state <= MEM; + MEM: seq_state <= FETCH; + default: seq_state <= FETCH; + endcase + end + + // operand register + assign operand = + (ins_load || ins_store || ins_branch || ins_cbranch) ? + { {(WIDTH-13){ins[12]}}, ins[12:1], 1'b0 } + : (ins_loadc) ? { {(WIDTH-13){ins[12]}}, ins[12:0] } // sign extend + : (ins_aluop || ins_mem) ? + { {(WIDTH-4){1'b0}}, ins[3:0] } + : (ins_loadrel) ? { {(WIDTH-10){1'b0}}, ins[9:0] } + : (ins_fpadj) ? { {(WIDTH-10){ins[9]}}, ins[9:0] } // sign extend + : { {WIDTH{1'b0}} }; + + // program counter + always @(posedge clk) + begin + if(reset) nPC <= 0; + else + case(seq_state) + EXEC: + if(ins_xfer && xfer_x2p) nPC <= X; + else if(ins_branch || (ins_cbranch && (x_is_zero != cbranch_n))) nPC <= PC + operand; + else nPC <= pc_next_ins; + MEM: + if(ins_xfer && xfer_r2p) nPC <= data_in; + else if(irq_pending) nPC <= IV; + endcase + end + + // return stack pointer + always @* + begin + if(seq_state == EXEC || seq_state == DECODE || seq_state == MEM) + begin + if (ins_xfer) nRP <= RP + + ({ {(ADDR_WIDTH-3){xfer_rs[1]}},xfer_rs} << WORDSIZE_SHIFT); + // sign extend xfer_rs and multiply by word size + else if (ins_storereg && ins_reg_rp) nRP <= X; + else nRP <= RP; + end + else nRP <= nRP; + end + + // instruction fetch + // depending on bit 1 of the PC, read either the upper or lower half word as an instruction + always @* if(seq_state == DECODE) ins <= PC[1] ? data_in[15:0] : data_in[31:16]; + + // RAM read/write + always @(posedge clk) + begin + if(reset) + begin + addr <= 0; + mem_write_data <= 0; + end + else + case(seq_state) + DECODE: + if(ins_load || ins_store) // read from address in BP/FP + offset + addr <= operand + ( loadstore_base ? BP: FP); + else if (ins_loadi) // read from address in X + addr <= X; + else if (ins_storei) // write to address in Y + addr <= Y; + else if (ins_loadrel) // read from address next to current instruction + addr <= PC + operand; + else if (ins_xfer && xfer_r2p) // read from return stack + addr <= RP; // use the current RP + else if (ins_xfer && xfer_p2r) // write to return stack + addr <= nRP; // use the new RP + EXEC: + begin + if (ins_store) + mem_write_data <= X; + else if (ins_storei) + mem_write_data <= X; + else if (ins_xfer && xfer_p2r) + mem_write_data <= pc_next_ins; + else + mem_write_data <= 0; + end + MEM: + if(!mem_wait) // do not change the address if mem_wait is active + begin + if(ins_xfer && xfer_r2p) addr <= data_in; // on RET take addr for next instruction from the data we just read from mem + else addr <= irq_pending ? IV : nPC; // prepare fetch cycle + end + endcase + end + + // X/ToS-Register + always @(posedge clk) + begin + if(reset) nX <= 0; + else + case(seq_state) + // default: nX <= X; + FETCH, DECODE:; + EXEC: + if(ins_loadc) nX <= operand; + else if(ins_cbranch || ins_store || ins_storereg || (ins_xfer && xfer_x2p)) nX <= Y; + else if(ins_storei) nX <= Y + operand; + else if(ins_loadreg && ins_reg_fp) nX <= FP; + else if(ins_loadreg && ins_reg_bp) nX <= BP; + else if(ins_loadreg && ins_reg_rp) nX <= RP; + else if(ins_loadreg && ins_reg_iv) nX <= IV; + else if(ins_loadreg && ins_reg_ir) nX <= IR; + else if(ins_loadreg && ins_reg_esp) nX <= ESP; + else if(ins_aluop) + begin + case(aluop) + 4'b0000: nX = X + Y; // ADD + 4'b0001: nX = Y - X; // SUB + 4'b0010: nX = ~X; // NOT + 4'b0011: nX = X & Y; // AND + 4'b0100: nX = X | Y; // OR + 4'b0101: nX = X ^ Y; // XOR + 4'b0110: nX = // CMP + cmp_i ^ ((cmp_e && x_equals_y) || (cmp_l && y_lessthan_x)); + 4'b0111: nX = Y; // Y + 4'b1000: nX = aluop_ext ? X >>> 1 : X >> 1; // SHR + 4'b1001: nX = operand[1] ? X << 2 : X << 1; // SHL + 4'b1010: nX = X + operand; // INC + 4'b1011: nX = X - operand; // DEC + 4'b1100: nX = // CMPU + cmp_i ^ ((cmp_e && x_equals_y) || (cmp_l && yx_unsigned_less)); + // 4'b1101: nX = X[7:0] << ((3 - Y[1:0]) << 3); // BPLC + 4'b1101: nX = Y[1:0] == 0 ? { X[7:0], 24'b0 } : + Y[1:0] == 1 ? { 8'b0, X[7:0], 16'b0 } : + Y[1:0] == 2 ? { 16'b0, X[7:0], 8'b0 } : + { 24'b0, X[7:0]}; // BPLC + 4'b1110: nX = { X[23:16], X[15:8], X[7:0], X[31:24] }; // BROT + 4'b1111: nX = { 24'b0, Y[1:0] == 0 ? X[31:24] : Y[1:0] == 1 ? X[23:16] : + Y[1:0] == 2 ? X[15: 8] : X[7:0] }; // BSEL +// 4'b1110: nX = X * Y; // MUL +// 4'b1111: nX = X / Y; // DIV + default: nX = X; + endcase + end + MEM: + if (ins_loadi || ins_load || ins_loadrel) + nX = data_in; + endcase + end + + // estack movement + wire [EVAL_STACK_INDEX_WIDTH-1:0] delta = + ((ins_load || ins_loadc || ins_loadreg || ins_loadrel)) ? 1 + : ((ins_aluop || ins_loadi || ins_storei || ins_xfer)) ? + { {(EVAL_STACK_INDEX_WIDTH-2){aluop_sd[1]}},aluop_sd} // sign extend + : ((ins_store || ins_cbranch || ins_xfer || ins_storereg)) ? -1 + : 0; + + + always @* + begin + if(reset) + nESP <= 0; + else + if(seq_state == EXEC) + begin + nESP = ESP + delta; + end + end + + always @(posedge clk) + begin + // when to write (old) X back to stack (new Y) + // stack write is a reg so it is 1 in the next cycle i.e. MEM state + stack_write <= (seq_state == EXEC && + (ins_load || ins_loadc || ins_loadrel || ins_loadreg + || ((ins_loadi || ins_storei || ins_aluop) && aluop_x2y))); + end + + // FP register + always @(posedge clk) + begin + if(seq_state == EXEC) + begin + if(ins_fpadj) FP <= FP + operand; + else if(ins_storereg && ins_reg_fp) FP <= X; + end + end + + // BP register + always @(posedge clk) if(seq_state == EXEC && ins_storereg && ins_reg_bp) BP <= X; + + // IV register + always @(posedge clk) + begin + if(reset) + IV <= 0; + else if(seq_state == EXEC && ins_storereg && ins_reg_iv) + IV <= X; + end + + // IR register + always @(posedge clk) + begin + if(seq_state == MEM && irq_pending) IR <= nPC; // use nPC as interrupt return addr + end + + // process irq + always @(posedge clk) + begin + if(seq_state == MEM && irq_pending && !(ins_xfer & xfer_r2p)) // in FETCH state, clear irq_pending. + irq_pending <= 0; + else + irq_pending <= irq_pending || irq; // else set irq_pending when irq is high + end + + // advance CPU state + always @ (posedge clk) + begin + if(reset) + { PC, X, ESP, RP } <= { {WIDTH{1'b0}}, {WIDTH{1'b0}}, {WIDTH{1'b0}}, {WIDTH{1'b0}} }; + else if(seq_state == FETCH) + { PC, X, ESP, RP } <= { nPC, nX, nESP, nRP}; + end +endmodule diff --git a/rtl/src/testbench.v b/rtl/src/testbench.v new file mode 100644 index 0000000..8d26bb4 --- /dev/null +++ b/rtl/src/testbench.v @@ -0,0 +1,54 @@ +`timescale 1ns/1ps +`default_nettype none + +module testbench(); + reg clk; + reg rst_n; + wire btn0; + wire sw0; + wire sw1; + wire led0; + wire led1; + wire led2; + wire led3; + wire uart_txd_in; + wire uart_rxd_out; + + wire [15:0] ddr3_dq; + wire [1:0] ddr3_dqs_n; + wire [1:0] ddr3_dqs_p; + wire [13:0] ddr3_addr; + wire [2:0] ddr3_ba; + wire ddr3_ras_n; + wire ddr3_cas_n; + wire ddr3_we_n; + wire ddr3_reset_n; + wire [0:0] ddr3_ck_p; + wire [0:0] ddr3_ck_n; + wire [0:0] ddr3_cke; + wire [0:0] ddr3_cs_n; + wire [1:0] ddr3_dm; + wire [0:0] ddr3_odt; + + integer t; + + top top0(clk, rst_n, btn0, sw0,sw1, led0, led1, led2, led3, uart_txd_in, uart_rxd_out, + ddr3_dq, ddr3_dqs_n, ddr3_dqs_p, ddr3_addr, ddr3_ba, ddr3_ras_n, ddr3_cas_n, + ddr3_we_n, ddr3_reset_n, ddr3_ck_p, ddr3_ck_n, ddr3_cke, ddr3_cs_n, ddr3_dm, ddr3_odt); + + initial begin + clk = 1; + t = 0; + rst_n = 0; + end + + always #5.0 clk = ~clk; + + always @(posedge clk) begin + t <= t + 1; + if (t == 2) + rst_n = 1; + if (t == 400) + $finish; + end +endmodule diff --git a/rtl/src/top.v b/rtl/src/top.v new file mode 100644 index 0000000..e79d611 --- /dev/null +++ b/rtl/src/top.v @@ -0,0 +1,288 @@ +`timescale 1ns / 1ps +// either define clock as clk (100MHz on Arty) +// or as clk_1hz for debugging + +`define clock cpuclk +`define clkfreq 83333333 +//`define clock clk +//`define clkfreq 100000000 +//`define clock clk_1hz +`define ENABLE_VGAFB +`define ENABLE_MICROSD + +module top( + input wire clk, + input wire rst, + input wire btn0, + input wire sw0, + input wire sw1, + output wire led0, + output wire led1, + output wire led2, + output wire led3, + input wire uart_txd_in, + output wire uart_rxd_out, + + // DDR3 SDRAM + inout wire [15:0] ddr3_dq, + inout wire [1:0] ddr3_dqs_n, + inout wire [1:0] ddr3_dqs_p, + + output wire [13:0] ddr3_addr, + output wire [2:0] ddr3_ba, + output wire ddr3_ras_n, + output wire ddr3_cas_n, + output wire ddr3_we_n, + output wire ddr3_reset_n, + output wire [0:0] ddr3_ck_p, + output wire [0:0] ddr3_ck_n, + output wire [0:0] ddr3_cke, + output wire [0:0] ddr3_cs_n, + output wire [1:0] ddr3_dm, + output wire [0:0] ddr3_odt + +`ifdef ENABLE_VGAFB + , + output wire [3:0] VGA_R, + output wire [3:0] VGA_G, + output wire [3:0] VGA_B, + + output wire VGA_HS_O, + output wire VGA_VS_O +`endif + +`ifdef ENABLE_MICROSD + , + output wire sd_cs_n, + output wire sd_mosi, + input wire sd_miso, + output wire sd_sck, + input wire sd_cd +`endif +); + + reg clk_1hz; + reg [31:0] counter; + + localparam ADDR_WIDTH = 32, WIDTH = 32, + ROMADDR_WIDTH = 11, IOADDR_WIDTH = 11, IOADDR_SEL = 4; + + wire [ADDR_WIDTH-1:0] mem_addr; + wire [WIDTH-1:0] mem_read_data; + wire [WIDTH-1:0] mem_write_data; + (* KEEP *) wire mem_wait; + + (* KEEP *) wire mem_read_enable; + (* KEEP *) wire mem_write_enable; + (* KEEP *) wire io_enable; + wire [WIDTH-1:0] io_rd_data; + wire [IOADDR_SEL-1:0] io_slot = mem_addr[IOADDR_WIDTH-1:IOADDR_WIDTH-IOADDR_SEL]; + + wire irq; + + // assign led0 = mem_wait; + + wire [WIDTH-1:0] debug_data1, debug_data2, + debug_data3, debug_data4, + debug_data5, debug_data6; + + assign led0 = debug_data6[0]; + + wire cpuclk, cpuclk_locked; + wire dram_refclk200; + wire pixclk; + cpu_clkgen cpuclk_0(~rst, clk, cpuclk, dram_refclk200, pixclk, cpuclk_locked); + + // DRAM -------------------------------------------------------------------------- + wire [ADDR_WIDTH-1:0] dram_addr; + wire [WIDTH-1:0] dram_read_data, dram_write_data; + wire dram_read_enable, dram_write_enable, dram_wait; + + dram_bridge dram_bridge0 (dram_addr, + dram_read_data, dram_write_data, dram_read_enable, dram_write_enable, dram_wait, + rst, cpuclk, dram_refclk200, + ddr3_dq, ddr3_dqs_n, ddr3_dqs_p, ddr3_addr, + ddr3_ba, ddr3_ras_n, ddr3_cas_n, ddr3_we_n, + ddr3_reset_n, ddr3_ck_p, ddr3_ck_n, ddr3_cke, + ddr3_cs_n, ddr3_dm, ddr3_odt); + + mem #(.ADDR_WIDTH(ADDR_WIDTH), .DATA_WIDTH(WIDTH)) mem0( + .clk(`clock), .rst_n(rst), .addr(mem_addr), + .data_out(mem_read_data), .read_enable(mem_read_enable), + .data_in(mem_write_data), .write_enable(mem_write_enable), + .io_enable(io_enable), + .io_rd_data(io_rd_data), + .mem_wait(mem_wait), + .dram_addr(dram_addr), + .dram_read_data(dram_read_data), + .dram_write_data(dram_write_data), + .dram_read_enable(dram_read_enable), + .dram_write_enable(dram_write_enable), + .dram_wait(dram_wait) + ); + +`ifdef ENABLE_VGAFB + localparam FB_ADDR_WIDTH = 14; + wire [FB_ADDR_WIDTH-1:0] fb_rd_addr; + wire [FB_ADDR_WIDTH-1:0] fb_wr_addr; + wire [WIDTH-1:0] fb_rd_data; + wire [WIDTH-1:0] fb_wr_data; + wire fb_rd_en, fb_wr_en; + + wire fb_cs_en = io_enable && (io_slot == 2); + + assign fb_rd_en = fb_cs_en && mem_read_enable; + assign fb_wr_en = fb_cs_en && mem_write_enable; + assign fb_wr_data = mem_write_data; + + vgafb vgafb0(`clock, pixclk, rst, + mem_addr[3:0], fb_rd_data, fb_wr_data, + fb_rd_en, fb_wr_en, + VGA_HS_O, VGA_VS_O, VGA_R, VGA_G, VGA_B); +`endif + + // SPI SD card controller ------------------------------------------------------------------- +`ifdef ENABLE_MICROSD + wire [7:0] spi_tx_data; + (*KEEP*) wire [7:0] spi_rx_data; + wire spi_tx_ready; // ready to transmit new data + wire spi_tx_empty; // tx fifo is empty + wire spi_rx_avail; // a byte has been received + wire spi_rx_ovr; // receiver overrun + wire spi_tx_write; // write strobe + wire spi_rx_read; // read strobe (clears rx_avail) + + wire spi_card_detect; // true is card is present + wire spi_card_changed; // card_detect signal has changed + wire spi_card_busy; // card is busy (MISO/DO is 0) + + wire spi_ctrl_write; // set the following flags + wire spi_rx_filter_en; // set to wait for start bit (1-to-0) when receiving + wire spi_txrx_en; // enable transmitter and receiver + wire spi_sclk_f_en; // enable spi clock without transceiver + wire spi_sclk_div_wr; // set clock divider from tx_data + + wire spi_cs; // cs signal for spi controller + wire [WIDTH-1:0] spi_rd_data; + + assign spi_cs = io_enable && (io_slot == 1); + + // spi read data: [ 0,...,0,cd,cc,cb,tr,te,ra,ro,d,d,d,d,d,d,d,d ] + // cd = card detect, cc = card changed, cb = card busy, + // tr = transmitter ready, te = tx fifo empty, + // ra = received byte available, ro = receive overrun, d = received byte + assign spi_rd_data = + { {WIDTH-15{1'b0}}, spi_card_detect, spi_card_changed, spi_card_busy, + spi_tx_ready, spi_tx_empty, + spi_rx_avail, spi_rx_ovr, spi_rx_data }; + + // spi write data: [ 0,...,0,CW,CF,Cx,Cc,Cd,DR,DW,d,d,d,d,d,d,d,d ] + // 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 to be sent + assign spi_ctrl_write = spi_cs && mem_write_enable && mem_write_data[14]; + assign spi_rx_filter_en = mem_write_data[13]; + assign spi_txrx_en = mem_write_data[12]; + assign spi_sclk_f_en = mem_write_data[11]; + assign spi_sclk_div_wr = spi_cs && mem_write_enable && mem_write_data[10]; + assign spi_rx_read = mem_write_data[9]; + assign spi_tx_write = spi_cs && mem_write_enable && mem_write_data[8]; + assign spi_tx_data = mem_write_data[7:0]; + + sdspi sdspi0(.clk(`clock), .reset(~rst), + .tx_data(spi_tx_data), .rx_data(spi_rx_data), + .tx_ready(spi_tx_ready), .tx_empty(spi_tx_empty), + .rx_avail(spi_rx_avail), .rx_ovr(spi_rx_ovr), + .tx_write(spi_tx_write), .rx_read(spi_rx_read), + .card_detect(spi_card_detect), .card_changed(spi_card_changed), .card_busy(spi_card_busy), + // ctrl_write is used with rx_filter_en, txrx_en and spiclk_f_en + .ctrl_write(spi_ctrl_write), + .rx_filter_en(spi_rx_filter_en), .txrx_en(spi_txrx_en), .spiclk_f_en(spi_sclk_f_en), + // + .spiclk_div_wr(spi_sclk_div_wr), + .sd_cs_n(sd_cs_n), + .sd_mosi(sd_mosi), .sd_miso(sd_miso), .sd_sck(sd_sck), .sd_cd(sd_cd)); +`endif + + // UART ----------------------------------------------------------------------- + + // uart write data: [ 0, 0, 0, 0, 0, T, C, 0, c, c, c, c, c, c, c, c ] + // T = transmit enable, C = receiver clear, c = 8-bit-character + // uart read data: [ 0, 0, 0, 0, 0, 0, A, B, c, c, c, c, c, c, c, c ] + // A = char available, B = tx busy, c = 8-bit-character + wire uart_cs = io_enable && (io_slot == 0); + wire uart_tx_en = uart_cs && mem_write_enable && mem_write_data[10]; + wire uart_rx_clear = uart_cs && mem_write_enable && mem_write_data[9]; + wire uart_rx_avail; + wire uart_rx_busy, uart_tx_busy; + wire uart_err; + wire [7:0] uart_rx_data; + wire [7:0] uart_tx_data; + wire [31:0] uart_baud = 32'd115200; + wire [WIDTH-1:0] uart_rd_data; + + assign uart_tx_data = mem_write_data[7:0]; + assign uart_rd_data = { {WIDTH-10{1'b1}}, uart_rx_avail, uart_tx_busy, uart_rx_data }; + + reg timer_tick; + reg[23:0] tick_count; + wire [1:0] irq_in = { timer_tick, uart_rx_avail }; + wire [1:0] irqc_rd_data0; + wire [WIDTH-1:0] irqc_rd_data = { tick_count, 6'b0, irqc_rd_data0 }; + wire irqc_seten = mem_write_data[7]; + wire irqc_cs = io_enable && (io_slot == 3); + + assign io_rd_data = (io_slot == 0) ? uart_rd_data : + `ifdef ENABLE_MICROSD + (io_slot == 1) ? spi_rd_data : + `endif + `ifdef ENABLE_VGAFB + (io_slot == 2) ? fb_rd_data : + `endif + (io_slot == 3) ? irqc_rd_data: + + -1; + + buart #(.CLKFREQ(`clkfreq)) uart0(`clock, rst, + uart_baud, + uart_txd_in, uart_rxd_out, + uart_rx_clear, uart_tx_en, + uart_rx_avail, uart_tx_busy, + uart_tx_data, uart_rx_data); + + // CPU ----------------------------------------------------------------- + stackcpu cpu0(.clk(`clock), .rst(rst), .irq(irq), + .addr(mem_addr), + .data_in(mem_read_data), .read_enable(mem_read_enable), + .data_out(mem_write_data), .write_enable(mem_write_enable), + .mem_wait(mem_wait), + .led1(led1), .led2(led2), .led3(led3), + .debug_out1(debug_data1), + .debug_out2(debug_data2), + .debug_out3(debug_data3), + .debug_out4(debug_data4), + .debug_out5(debug_data5), + .debug_out6(debug_data6)); + + // Interrupt Controller + irqctrl irqctrl0(`clock, irq_in, irqc_cs, mem_write_enable, + irqc_seten, irqc_rd_data0, + irq); + + // count clock ticks + // generate interrupt every 20nth of a second + always @ (posedge `clock) + begin + counter <= counter + 1; + if (counter >= (`clkfreq/20)) + begin + counter <= 0; + timer_tick <= 1; + tick_count <= tick_count + 1'b1; + end + else + begin + timer_tick <= 0; + end + end +endmodule diff --git a/rtl/src/uart.v b/rtl/src/uart.v new file mode 100644 index 0000000..fec26a3 --- /dev/null +++ b/rtl/src/uart.v @@ -0,0 +1,262 @@ +/* +Copyright (c) 2010-2020, James Bowman +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* 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. + +* Neither the name of swapforth 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. +*/ + + +`default_nettype none +//`define def_clkfreq 100000000 +`define def_clkfreq 83333333 + +module baudgen( + input wire clk, + input wire resetq, + input wire [31:0] baud, + input wire restart, + output wire ser_clk); + parameter CLKFREQ = `def_clkfreq; + + wire [38:0] aclkfreq = CLKFREQ; + reg [38:0] d; + wire [38:0] dInc = d[38] ? ({4'd0, baud}) : (({4'd0, baud}) - aclkfreq); + wire [38:0] dN = restart ? 0 : (d + dInc); + wire fastclk = ~d[38]; + assign ser_clk = fastclk; + + always @(negedge resetq or posedge clk) + begin + if (!resetq) begin + d <= 0; + end else begin + d <= dN; + end + end +endmodule + +/* + +-----+ +-----+-----+-----+-----+-----+-----+-----+-----+-----+-----+---- + | | | | | | | | | | | | + |start| 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 |stop1|stop2| + | | | | | | | | | | | ? | + +-----+-----+-----+-----+-----+-----+-----+-----+-----+ + + +*/ + +module uart( + input wire clk, // System clock + input wire resetq, + + // Outputs + output wire uart_busy, // High means UART is transmitting + output reg uart_tx, // UART transmit wire + // Inputs + input wire [31:0] baud, + input wire uart_wr_i, // Raise to transmit byte + input wire [7:0] uart_dat_i // 8-bit data +); + parameter CLKFREQ = `def_clkfreq; + + reg [3:0] bitcount; + reg [8:0] shifter; + + assign uart_busy = |bitcount; + wire sending = |bitcount; + + wire ser_clk; + + wire starting = uart_wr_i & ~uart_busy; + baudgen #(.CLKFREQ(CLKFREQ)) _baudgen( + .clk(clk), + .resetq(resetq), + .baud(baud), + .restart(1'b0), + .ser_clk(ser_clk)); + + always @(negedge resetq or posedge clk) + begin + if (!resetq) begin + uart_tx <= 1; + bitcount <= 0; + shifter <= 0; + end else begin + if (starting) begin + shifter <= { uart_dat_i[7:0], 1'b0 }; + bitcount <= 1 + 8 + 1; + end + + if (sending & ser_clk) begin + { shifter, uart_tx } <= { 1'b1, shifter }; + bitcount <= bitcount - 4'd1; + end + end + end + +endmodule + +module rxuart( + input wire clk, + input wire resetq, + input wire [31:0] baud, + input wire uart_rx, // UART recv wire + input wire rd, // read strobe + output wire valid, // has data + output wire [7:0] data); // data + parameter CLKFREQ = `def_clkfreq; + + reg [4:0] bitcount; + reg [7:0] shifter; + + // On starting edge, wait 3 half-bits then sample, and sample every 2 bits thereafter + + wire idle = &bitcount; + wire sample; + reg [2:0] hh = 3'b111; + wire [2:0] hhN = {hh[1:0], uart_rx}; + wire startbit = idle & (hhN[2:1] == 2'b10); + wire [7:0] shifterN = sample ? {hh[1], shifter[7:1]} : shifter; + + wire ser_clk; + baudgen #(.CLKFREQ(CLKFREQ)) _baudgen( + .clk(clk), + .baud({baud[30:0], 1'b0}), + .resetq(resetq), + .restart(startbit), + .ser_clk(ser_clk)); + + assign valid = (bitcount == 18); + reg [4:0] bitcountN; + always @* + if (startbit) + bitcountN = 0; + else if (!idle & !valid & ser_clk) + bitcountN = bitcount + 5'd1; + else if (valid & rd) + bitcountN = 5'b11111; + else + bitcountN = bitcount; + + // 3,5,7,9,11,13,15,17 + assign sample = (bitcount > 2) & bitcount[0] & !valid & ser_clk; + assign data = shifter; + + always @(negedge resetq or posedge clk) + begin + if (!resetq) begin + hh <= 3'b111; + bitcount <= 5'b11111; + shifter <= 0; + end else begin + hh <= hhN; + bitcount <= bitcountN; + shifter <= shifterN; + end + end +endmodule + +module fifo_rxuart( + input wire clk, + input wire resetq, + input wire [31:0] baud, + input wire uart_rx, // UART recv wire + input wire rd, // read strobe + output wire valid, // has data + output wire [7:0] data); // data + parameter CLKFREQ = `def_clkfreq; + + localparam ADDR_WIDTH = 6; + localparam DATA_WIDTH = 8; + + reg fifo_wr_en; + (*KEEP*) wire fifo_rd_en, fifo_full, fifo_empty; + wire [DATA_WIDTH-1:0] fifo_wr_data, fifo_rd_data; + (*KEEP*) wire rx_avail; + + assign valid = !fifo_empty; + assign data = fifo_rd_data; + assign fifo_rd_en = rd; + + fifo #(.ADDR_WIDTH(ADDR_WIDTH)) rx_fifo(clk, ~resetq, + fifo_wr_en, fifo_rd_en, + fifo_wr_data, fifo_rd_data, + fifo_full, + fifo_empty + ); + + rxuart #(.CLKFREQ(CLKFREQ)) _rx ( + .clk(clk), + .resetq(resetq), + .baud(baud), + .uart_rx(uart_rx), + .rd(fifo_wr_en), // strobe read signal on fifo write + .valid(rx_avail), + .data(fifo_wr_data)); + + always @(posedge clk) + begin + if (!resetq) + fifo_wr_en <= 0; + else if(!fifo_wr_en && rx_avail) // ILA shows fifo_wr_en stays 0 ?? + fifo_wr_en <= 1; // pulse fifo_wr_en for one clock + else // rx_avail goes zero one clock later + fifo_wr_en <= 0; + end +endmodule + +module buart( + input wire clk, + input wire resetq, + input wire [31:0] baud, + input wire rx, // recv wire + output wire tx, // xmit wire + input wire rd, // read strobe + input wire wr, // write strobe + output wire valid, // has recv data + output wire busy, // is transmitting + input wire [7:0] tx_data, + output wire [7:0] rx_data // data +); + parameter CLKFREQ = `def_clkfreq; + + fifo_rxuart #(.CLKFREQ(CLKFREQ)) _rx ( + .clk(clk), + .resetq(resetq), + .baud(baud), + .uart_rx(rx), + .rd(rd), + .valid(valid), + .data(rx_data)); + uart #(.CLKFREQ(CLKFREQ)) _tx ( + .clk(clk), + .resetq(resetq), + .baud(baud), + .uart_busy(busy), + .uart_tx(tx), + .uart_wr_i(wr), + .uart_dat_i(tx_data)); +endmodule diff --git a/rtl/src/uart_tb.v b/rtl/src/uart_tb.v new file mode 100644 index 0000000..7f794a2 --- /dev/null +++ b/rtl/src/uart_tb.v @@ -0,0 +1,100 @@ +////////////////////////////////////////////////////////////////////// +// File Downloaded from http://www.nandland.com +////////////////////////////////////////////////////////////////////// + +// This testbench will exercise both the UART Tx and Rx. +// It sends out byte 0xAB over the transmitter +// It then exercises the receive by receiving byte 0x3F +`timescale 1ns/10ps + +module uart_tb (); + + // Testbench uses a 10 MHz clock + // Want to interface to 115200 baud UART + // 10000000 / 115200 = 87 Clocks Per Bit. + parameter c_CLOCK_PERIOD_NS = 100; + parameter c_CLKS_PER_BIT = 87; + parameter c_BIT_PERIOD = 8600; + + reg r_Clock = 0; + reg r_Tx_DV = 0; + wire w_Tx_Done; + reg [7:0] r_Tx_Byte = 0; + reg r_Rx_Serial = 1; + wire [7:0] w_Rx_Byte; + + + // Takes in input byte and serializes it + task UART_WRITE_BYTE; + input [7:0] i_Data; + integer ii; + begin + + // Send Start Bit + r_Rx_Serial <= 1'b0; + #(c_BIT_PERIOD); + #1000; + + + // Send Data Byte + for (ii=0; ii<8; ii=ii+1) + begin + r_Rx_Serial <= i_Data[ii]; + #(c_BIT_PERIOD); + end + + // Send Stop Bit + r_Rx_Serial <= 1'b1; + #(c_BIT_PERIOD); + end + endtask // UART_WRITE_BYTE + + + uart_rx #(.CLKS_PER_BIT(c_CLKS_PER_BIT)) UART_RX_INST + (.i_Clock(r_Clock), + .i_Rx_Serial(r_Rx_Serial), + .o_Rx_DV(), + .o_Rx_Byte(w_Rx_Byte) + ); + + uart_tx #(.CLKS_PER_BIT(c_CLKS_PER_BIT)) UART_TX_INST + (.i_Clock(r_Clock), + .i_Tx_DV(r_Tx_DV), + .i_Tx_Byte(r_Tx_Byte), + .o_Tx_Active(), + .o_Tx_Serial(), + .o_Tx_Done(w_Tx_Done) + ); + + + always + #(c_CLOCK_PERIOD_NS/2) r_Clock <= !r_Clock; + + + // Main Testing: + initial + begin + + // Tell UART to send a command (exercise Tx) + @(posedge r_Clock); + @(posedge r_Clock); + r_Tx_DV <= 1'b1; + r_Tx_Byte <= 8'hAB; + @(posedge r_Clock); + r_Tx_DV <= 1'b0; + @(posedge w_Tx_Done); + + // Send a command to the UART (exercise Rx) + @(posedge r_Clock); + UART_WRITE_BYTE(8'h3F); + @(posedge r_Clock); + + // Check that the correct command was received + if (w_Rx_Byte == 8'h3F) + $display("Test Passed - Correct Byte Received"); + else + $display("Test Failed - Incorrect Byte Received"); + + end + +endmodule \ No newline at end of file diff --git a/rtl/src/vgafb.v b/rtl/src/vgafb.v new file mode 100644 index 0000000..4e8d668 --- /dev/null +++ b/rtl/src/vgafb.v @@ -0,0 +1,292 @@ +`timescale 1ns / 1ps +`default_nettype none + +// Project F: Display Timings +// (C)2019 Will Green, Open Source Hardware released under the MIT License +// Learn more at https://projectf.io + +//128K video memory is not enough for 640x480x4 +`define RES_640_400 +//`define RES_1024_768 + +module display_timings #( + H_RES=640, // horizontal resolution (pixels) + V_RES=480, // vertical resolution (lines) + H_FP=16, // horizontal front porch + H_SYNC=96, // horizontal sync + H_BP=48, // horizontal back porch + V_FP=10, // vertical front porch + V_SYNC=2, // vertical sync + V_BP=33, // vertical back porch + H_POL=0, // horizontal sync polarity (0:neg, 1:pos) + V_POL=0 // vertical sync polarity (0:neg, 1:pos) + ) + ( + input wire i_pix_clk, // pixel clock + input wire i_rst, // reset: restarts frame (active high) + output wire o_hs, // horizontal sync + output wire o_vs, // vertical sync + output wire o_de, // display enable: high during active video + output wire o_frame, // high for one tick at the start of each frame + output wire o_scanline, // high for one tick at the start of each scanline + output reg o_vblank, // high during vertical blank phase + output reg signed [15:0] o_sx, // horizontal beam position (including blanking) + output reg signed [15:0] o_sy // vertical beam position (including blanking) + ); + + // Horizontal: sync, active, and pixels + localparam signed H_STA = 0 - H_FP - H_SYNC - H_BP; // horizontal start + localparam signed HS_STA = H_STA + H_FP; // sync start + localparam signed HS_END = HS_STA + H_SYNC; // sync end + localparam signed HA_STA = 0; // active start + localparam signed HA_END = H_RES - 1; // active end + + // Vertical: sync, active, and pixels + localparam signed V_STA = 0 - V_FP - V_SYNC - V_BP; // vertical start + localparam signed VS_STA = V_STA + V_FP; // sync start + localparam signed VS_END = VS_STA + V_SYNC; // sync end + localparam signed VA_STA = 0; // active start + localparam signed VA_END = V_RES - 1; // active end + + // generate sync signals with correct polarity + assign o_hs = H_POL ? (o_sx > HS_STA && o_sx <= HS_END) + : ~(o_sx > HS_STA && o_sx <= HS_END); + assign o_vs = V_POL ? (o_sy > VS_STA && o_sy <= VS_END) + : ~(o_sy > VS_STA && o_sy <= VS_END); + + // display enable: high during active period + assign o_de = (o_sx >= 0 && o_sy >= 0); + + // o_frame: high for one tick at the start of each frame + assign o_frame = (o_sy == V_STA && o_sx == H_STA); + // o_scanline: high for one tick at the start of each visible scanline + assign o_scanline = (o_sy >= VA_STA) && (o_sy <= VA_END) && (o_sx == H_STA); + + always @(posedge i_pix_clk) + begin + if(o_frame) o_vblank <= 1; + else if (o_de) o_vblank <= 0; + end + + always @ (posedge i_pix_clk) + begin + if (i_rst) // reset to start of frame + begin + o_sx <= H_STA; + o_sy <= V_STA; + end + else + begin + if (o_sx == HA_END) // end of line + begin + o_sx <= H_STA; + if (o_sy == VA_END) // end of frame + o_sy <= V_STA; + else + o_sy <= o_sy + 16'sh1; + end + else + o_sx <= o_sx + 16'sh1; + end + end +endmodule + +// Project F: Display Controller VGA Demo +// (C)2020 Will Green, Open source hardware released under the MIT License +// Learn more at https://projectf.io + +// This demo requires the following Verilog modules: +// * display_clocks +// * display_timings +// * test_card_simple or another test card + +module vgafb #(VMEM_ADDR_WIDTH = 15, VMEM_DATA_WIDTH = 32) ( + input wire cpu_clk, // cpu clock + input wire CLK, // pixel clock + input wire RST_BTN, // reset button + input wire[3:0] reg_sel, // register select/address + output wire [VMEM_DATA_WIDTH-1:0] rd_data, + input wire [VMEM_DATA_WIDTH-1:0] wr_data, + input wire rd_en, + input wire wr_en, + + output wire VGA_HS, // horizontal sync output + output wire VGA_VS, // vertical sync output + output wire [3:0] VGA_R, // 4-bit VGA red output + output wire [3:0] VGA_G, // 4-bit VGA green output + output wire [3:0] VGA_B // 4-bit VGA blue output + ); + + localparam BITS_PER_PIXEL = 4; localparam MAX_SHIFT_COUNT = 7; + localparam REG_RD_ADDR = 0; localparam REG_WR_ADDR = 1; localparam REG_VMEM = 2; + localparam REG_PAL_SLOT = 3; localparam REG_PAL_DATA = 4; + localparam REG_CTL = 5; + + localparam COLOR_WIDTH = 12; + localparam PALETTE_WIDTH = 4; + + // Display Clocks + wire pix_clk = CLK; // pixel clock + wire clk_lock = 1; // clock locked? + + wire vmem_rd_en; + wire vmem_wr_en; + wire [VMEM_DATA_WIDTH-1:0] vmem_rd_data; + reg [VMEM_ADDR_WIDTH-1:0] cpu_rd_addr; + reg [VMEM_ADDR_WIDTH-1:0] cpu_wr_addr; + reg [VMEM_ADDR_WIDTH-1:0] pix_addr; + wire [VMEM_DATA_WIDTH-1:0] pix_data; + wire pix_rd; + wire [VMEM_DATA_WIDTH-1:0] status; + + assign vmem_rd_en = rd_en; + assign vmem_wr_en = (reg_sel == REG_VMEM) && wr_en; + assign rd_data = (reg_sel == REG_VMEM) ? vmem_rd_data : + (reg_sel == REG_RD_ADDR) ? cpu_rd_addr : + (reg_sel == REG_WR_ADDR) ? cpu_wr_addr : + (reg_sel == REG_CTL) ? status : + 32'hFFFFFFFF; + + wire [VMEM_ADDR_WIDTH-1:0] cpu_addr = vmem_wr_en ? cpu_wr_addr : cpu_rd_addr; + + bram_tdp #(.DATA(VMEM_DATA_WIDTH),.ADDR(VMEM_ADDR_WIDTH)) vram0 ( + .a_rd(vmem_rd_en), .a_clk(cpu_clk), + .a_wr(vmem_wr_en), .a_addr(cpu_addr), .a_din(wr_data), + .a_dout(vmem_rd_data), + .b_clk(pix_clk), .b_addr(pix_addr), .b_dout(pix_data), + .b_rd(pix_rd) + ); + + wire palette_wr_en = (reg_sel == REG_PAL_DATA) && wr_en; + reg [PALETTE_WIDTH-1:0] palette_wr_slot; + wire [COLOR_WIDTH-1:0] color_data; + + palette palette0(.wr_clk(cpu_clk), .rd_clk(pix_clk), .wr_en(palette_wr_en), + .wr_slot(palette_wr_slot), .wr_data(wr_data[COLOR_WIDTH-1:0]), + .rd_slot(pixel[3:0]), .rd_data(color_data)); + + // Display Timings + wire signed [15:0] sx; // horizontal screen position (signed) + wire signed [15:0] sy; // vertical screen position (signed) + wire h_sync; // horizontal sync + wire v_sync; // vertical sync + wire de; // display enable + wire frame; // frame start + wire scanline; // scanline start + wire vblank; // vertical blank + reg vblank_buf; // vertical blank in cpu clock domain + + display_timings #( // 640x480 800x600 1280x720 1920x1080 +`ifdef RES_1024_768 + .H_RES(1024), // 640 800 1280 1920 + .V_RES(768), // 480 600 720 1080 + .H_FP(24), // 16 40 110 88 + .H_SYNC(136), // 96 128 40 44 + .H_BP(160), // 48 88 220 148 + .V_FP(3), // 10 1 5 4 + .V_SYNC(6), // 2 4 5 5 + .V_BP(29), // 33 23 20 36 + .H_POL(0), // 0 1 1 1 + .V_POL(0) // 0 1 1 1 + `endif + `ifdef RES_640_400 + .H_RES(640), + .V_RES(400), + .H_FP(16), + .H_SYNC(96), + .H_BP(48), + .V_FP(12), + .V_SYNC(2), + .V_BP(35), + .H_POL(0), + .V_POL(1) + `endif + ) + display_timings_inst ( + .i_pix_clk(CLK), + .i_rst(!RST_BTN), + .o_hs(h_sync), + .o_vs(v_sync), + .o_de(de), + .o_frame(frame), + .o_scanline(scanline), + .o_vblank(vblank), + .o_sx(sx), + .o_sy(sy) + ); + + wire [7:0] red; + wire [7:0] green; + wire [7:0] blue; + + reg [VMEM_DATA_WIDTH-1:0] shifter; + reg [4:0] shift_count; + + // delayed frame signal for pix_rd + reg frame_d; + + assign pix_rd = frame_d || scanline || (shift_count == 2); + + assign status = { 4'b0001, {(VMEM_DATA_WIDTH-5){1'b0}}, vblank_buf}; + + wire [BITS_PER_PIXEL-1:0] pixel = shifter[VMEM_DATA_WIDTH-1:VMEM_DATA_WIDTH-BITS_PER_PIXEL]; + + always @(posedge pix_clk) frame_d <= frame; + + always @(posedge cpu_clk) vblank_buf <= vblank; + + always @(posedge cpu_clk) + begin + if(wr_en) + begin + case(reg_sel) + REG_RD_ADDR: cpu_rd_addr <= wr_data; + REG_WR_ADDR: cpu_wr_addr <= wr_data; + REG_VMEM: cpu_wr_addr <= cpu_wr_addr + 1; // auto-increment write addr on write + REG_PAL_SLOT: palette_wr_slot <= wr_data[3:0]; + endcase + end + else + if(rd_en && reg_sel == REG_VMEM) cpu_rd_addr <= cpu_rd_addr + 1; // auto-increment read addr on read + end + + always @(posedge pix_clk) + begin + if(scanline || shift_count == MAX_SHIFT_COUNT) // before start of a line + begin // or at the end of a word, reset shifter with pixel data + shift_count <= 0; + shifter <= pix_data; + end + else if(de) + begin + shift_count <= shift_count + 1; + shifter <= shifter << BITS_PER_PIXEL; + end + + if(frame) // at start of frame, reset pixel pointer + pix_addr <= 0; + else if(shift_count == 1) // after the first pixel, increment address + pix_addr <= pix_addr + 1; + end + +// Hard-Coded RGBI palette +// // Pixel = { red, green, blue, intensity } +// assign red = pixel[3] ? pixel[0] ? 255 : 127: 0; +// assign green = pixel[2] ? pixel[0] ? 255 : 127: 0; +// assign blue = pixel[1] ? pixel[0] ? 255 : 127: 0; + +// // VGA Output +// // VGA Pmod is 12-bit so we take the upper nibble of each colour +// assign VGA_HS = h_sync; +// assign VGA_VS = v_sync; +// assign VGA_R = de ? red[7:4] : 4'b0; +// assign VGA_G = de ? green[7:4] : 4'b0; +// assign VGA_B = de ? blue[7:4] : 4'b0; + + // 12 bit RGB palette + assign VGA_HS = h_sync; + assign VGA_VS = v_sync; + assign VGA_R = de ? color_data[11:8] : 4'b0; + assign VGA_G = de ? color_data[7:4] : 4'b0; + assign VGA_B = de ? color_data[3:0] : 4'b0; +endmodule diff --git a/tests/cchangetest.pas b/tests/cchangetest.pas new file mode 100644 index 0000000..589bdc6 --- /dev/null +++ b/tests/cchangetest.pas @@ -0,0 +1,8 @@ +program cchangetest; +var c:char; +begin + repeat + writeln('cardchanged: ', cardchanged); + read(c); + until c = #27; +end. diff --git a/tests/readchartest.pas b/tests/readchartest.pas new file mode 100644 index 0000000..8675493 --- /dev/null +++ b/tests/readchartest.pas @@ -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. diff --git a/tests/readtest.pas b/tests/readtest.pas new file mode 100644 index 0000000..4b3817a --- /dev/null +++ b/tests/readtest.pas @@ -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. diff --git a/tests/test109.pas b/tests/test109.pas new file mode 100644 index 0000000..9acc24b --- /dev/null +++ b/tests/test109.pas @@ -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. diff --git a/tests/test133.pas b/tests/test133.pas new file mode 100644 index 0000000..fd2209a --- /dev/null +++ b/tests/test133.pas @@ -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. diff --git a/tests/test159.pas b/tests/test159.pas new file mode 100644 index 0000000..58a0f0c --- /dev/null +++ b/tests/test159.pas @@ -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. diff --git a/tests/timetest.pas b/tests/timetest.pas new file mode 100644 index 0000000..a9dc544 --- /dev/null +++ b/tests/timetest.pas @@ -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. diff --git a/tests/tree.pas b/tests/tree.pas new file mode 100644 index 0000000..69f5345 --- /dev/null +++ b/tests/tree.pas @@ -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. diff --git a/tests/treeimpl.pas b/tests/treeimpl.pas new file mode 100644 index 0000000..39ee8fb --- /dev/null +++ b/tests/treeimpl.pas @@ -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; diff --git a/tests/treetypes.pas b/tests/treetypes.pas new file mode 100644 index 0000000..1228c86 --- /dev/null +++ b/tests/treetypes.pas @@ -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; diff --git a/tests/umlaut.pas b/tests/umlaut.pas new file mode 100644 index 0000000..68c1c50 --- /dev/null +++ b/tests/umlaut.pas @@ -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. diff --git a/tridoraemu/IOHandler.go b/tridoraemu/IOHandler.go new file mode 100644 index 0000000..27ded1e --- /dev/null +++ b/tridoraemu/IOHandler.go @@ -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) +} diff --git a/tridoraemu/LICENSE.md b/tridoraemu/LICENSE.md new file mode 100644 index 0000000..3755dbb --- /dev/null +++ b/tridoraemu/LICENSE.md @@ -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. diff --git a/tridoraemu/README.md b/tridoraemu/README.md new file mode 100644 index 0000000..0ec332b --- /dev/null +++ b/tridoraemu/README.md @@ -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, Alacritty, 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 *Examples* 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. diff --git a/tridoraemu/console.go b/tridoraemu/console.go new file mode 100644 index 0000000..0baa11b --- /dev/null +++ b/tridoraemu/console.go @@ -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 +} diff --git a/tridoraemu/console_windows.go b/tridoraemu/console_windows.go new file mode 100644 index 0000000..abb8aa8 --- /dev/null +++ b/tridoraemu/console_windows.go @@ -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 +} + diff --git a/tridoraemu/cpu.go b/tridoraemu/cpu.go new file mode 100644 index 0000000..c0c7739 --- /dev/null +++ b/tridoraemu/cpu.go @@ -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 +} diff --git a/tridoraemu/framebuffer.go b/tridoraemu/framebuffer.go new file mode 100644 index 0000000..4586287 --- /dev/null +++ b/tridoraemu/framebuffer.go @@ -0,0 +1,132 @@ +// 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 > (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) { +} diff --git a/tridoraemu/go.mod b/tridoraemu/go.mod new file mode 100644 index 0000000..f60b59a --- /dev/null +++ b/tridoraemu/go.mod @@ -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 +) diff --git a/tridoraemu/irqc.go b/tridoraemu/irqc.go new file mode 100644 index 0000000..38e5642 --- /dev/null +++ b/tridoraemu/irqc.go @@ -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 +} + diff --git a/tridoraemu/mem.go b/tridoraemu/mem.go new file mode 100644 index 0000000..4765c8b --- /dev/null +++ b/tridoraemu/mem.go @@ -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 +} diff --git a/tridoraemu/sdspi.go b/tridoraemu/sdspi.go new file mode 100644 index 0000000..169a5fb --- /dev/null +++ b/tridoraemu/sdspi.go @@ -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 +} + diff --git a/tridoraemu/tridoraemu.go b/tridoraemu/tridoraemu.go new file mode 100644 index 0000000..875c3c0 --- /dev/null +++ b/tridoraemu/tridoraemu.go @@ -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) + } +} diff --git a/tridoraemu/uart.go b/tridoraemu/uart.go new file mode 100644 index 0000000..8f2fb3a --- /dev/null +++ b/tridoraemu/uart.go @@ -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 +} + diff --git a/utils/tdrimg.py b/utils/tdrimg.py new file mode 100644 index 0000000..bb380ca --- /dev/null +++ b/utils/tdrimg.py @@ -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("../examples/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)