commit 65ee0cd1f41b427ffe48dd2ef9857d2361d355cd Author: slederer Date: Tue Sep 10 23:57:08 2024 +0200 Initial commit diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..542fd45 --- /dev/null +++ b/.gitignore @@ -0,0 +1,20 @@ +*.s +*.o +*.exe +*.bin +*.sym +*.swp +*.prog +*.out +*.dis +*.sasmout +*.lib +*.img +*.lsym +*.zip +sine.pas +graph.pas +graph2.pas +chase.pas +*.img +!runtime.s 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..25fa0c1 --- /dev/null +++ b/README.md @@ -0,0 +1,58 @@ +# Tridora +- the Tridora CPU and the Tridora System +- creating everything from the ground up (except soldering stuff) +- make it useful, but as simple as possible + +## Overview +- Homebrew CPU +- Verilog/FPGA SoC +- 32-bit word-oriented stack machine architecture +- has its own instruction set architecture, compatible with nothing +- additional IO controllers on FPGA: UART (serial console), SD-Card, VGA +- Pascal compiler written from zero +- CPU and compiler were designed together +- minimal operating system +- editor, compiler, assembler run natively +- so you can develop programs directly on the machine +- small: CPU has 760 lines of verilog, compiler ~9000 LoC +- Compiler written in Pascal and can compile itself +- Cross-compiler/-assembler can be compiled with FPC +- Compiler does its own Pascal dialect with some restrictions and some extensions +- Emulator available + +## Demo +- (Video hello world) +- (Video lines) +- (Screenshot mandelbrot) +- (Screenshot conway) +- (Screenshot image viewer) + +## Supported Boards +- Arty A7 +- Nexys A7? + +## Pascal Language +- Wirth Pascal +- no function types/parameters +- arbitrary length strings (2GB) +- safe strings (runtime information about max/current size) +- tiny sets (machine word sized), that means no SET OF CHAR +- array literals with IN-operator, which can replace most uses of SET OF CHAR +- nested procedures with some limitations +- 32 bit software floating point with low precision (5-6 digits) +- break and exit statements, no continue yet +- static variable initialization for global variables +- non-standard file i/o (because the standard sucks, obl. XKCD reference) + +## Standard Library +- everything from Wirth Pascal +- some things from TP3.0 +- some graphics functionality (to be expanded in the future) + +## Operating System +- not a real operating system, more of a program loader +- some assembly routines for I/O resident in memory +- one program image loaded at a time at a fixed address +- most parts of the operating system are contained in the program image +- file system is very primitive: only contiguous blocks, no subdirectories +- Simple shell reminiscent of TP3.0, edit, compile, run programs 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/5cubes.pas b/examples/5cubes.pas new file mode 100644 index 0000000..edaecaa --- /dev/null +++ b/examples/5cubes.pas @@ -0,0 +1,253 @@ +program five_cubes_in_a_row; +const MAX_Y = 400; + pi = 3.1415926; + +type pointtype = record x,y:integer end; + +var cube:array[1..6] of record + position:array[1..5] of record x,y,z:real end; + end; + c:char; + pcos,ncos,psin,nsin:real; + +procedure rotx(dir:integer); +var y1,z1:real;i,o:integer; +begin + if dir=1 then + for i:=1 to 6 do + for o:=1 to 5 do + begin + y1:=pcos*cube[i].position[o].y-psin*cube[i].position[o].z; + z1:=psin*cube[i].position[o].y+pcos*cube[i].position[o].z; + cube[i].position[o].y:=y1; + cube[i].position[o].z:=z1; + end + else + for i:=1 to 6 do + for o:=1 to 5 do + begin + y1:=ncos*cube[i].position[o].y-nsin*cube[i].position[o].z; + z1:=nsin*cube[i].position[o].y+ncos*cube[i].position[o].z; + cube[i].position[o].y:=y1; + cube[i].position[o].z:=z1 + end +end; + +procedure roty(dir:integer); +var x1,z1:real;i,o:integer; +begin + if dir=1 then + for i:=1 to 6 do + for o:=1 to 5 do + begin + x1:=pcos*cube[i].position[o].x-psin*cube[i].position[o].z; + z1:=psin*cube[i].position[o].x+pcos*cube[i].position[o].z; + cube[i].position[o].x:=x1; + cube[i].position[o].z:=z1; + end + else + for i:=1 to 6 do + for o:=1 to 5 do + begin + x1:=ncos*cube[i].position[o].x-nsin*cube[i].position[o].z; + z1:=nsin*cube[i].position[o].x+ncos*cube[i].position[o].z; + cube[i].position[o].x:=x1; + cube[i].position[o].z:=z1 + end +end; + +procedure rotz(dir:integer); +var y1,x1:real;i,o:integer; +begin + if dir=1 then + for i:=1 to 6 do + for o:=1 to 5 do + begin + y1:=pcos*cube[i].position[o].y-psin*cube[i].position[o].x; + x1:=psin*cube[i].position[o].y+pcos*cube[i].position[o].x; + cube[i].position[o].y:=y1; + cube[i].position[o].x:=x1; + end + else + for i:=1 to 6 do + for o:=1 to 5 do + begin + y1:=ncos*cube[i].position[o].y-nsin*cube[i].position[o].x; + x1:=nsin*cube[i].position[o].y+ncos*cube[i].position[o].x; + cube[i].position[o].y:=y1; + cube[i].position[o].x:=x1 + end +end; + +procedure display_cube(col:integer); +var i,o,a:integer;c:integer; + stran:array[1..4] of pointtype; + color:integer; +begin + for i:=1 to 6 do + if cube[i].position[5].z>0 then + with cube[i] do + begin + for a:=1 to 5 do + begin + if col>0 then c:=a else c:=0; + if((a=4)and(c>0))then color :=6 else color:= c; + for o:=1 to 4 do + begin + stran[o].x:=a*100+round(position[o].x); + stran[o].y:=MAX_Y div 2+round(position[o].y); + end; + drawline(stran[1].x,stran[1].y,stran[2].x,stran[2].y,color); + drawline(stran[2].x,stran[2].y,stran[3].x,stran[3].y,color); + drawline(stran[3].x,stran[3].y,stran[4].x,stran[4].y,color); + drawline(stran[4].x,stran[4].y,stran[1].x,stran[1].y,color); + end; + end; +end; + +procedure init; +var i,gm,gd:integer; + entrance:array[1..11]of integer; +begin + entrance := [ 1,2,3,4,5,20,7,56,57,58,59 ]; + InitGraphics; + ClearGraphics; + pcos:=cos(6*2*pi/360); + ncos:=cos(-6*2*pi/360); + psin:=sin(6*2*pi/360); + nsin:=sin(-6*2*pi/360); + setpalette(1,$700); + with cube[1] do + begin + position[1].x:=-25; + position[1].y:=-25; + position[1].z:=+25; + position[2].x:=+25; + position[2].y:=-25; + position[2].z:=+25; + position[3].x:=+25; + position[3].y:=+25; + position[3].z:=+25; + position[4].x:=-25; + position[4].y:=+25; + position[4].z:=+25; + position[5].x:=0; + position[5].y:=0; + position[5].z:=25; + end; + with cube[2] do + begin + position[1].x:=-25; + position[1].y:=-25; + position[1].z:=-25; + position[2].x:=+25; + position[2].y:=-25; + position[2].z:=-25; + position[3].x:=+25; + position[3].y:=-25; + position[3].z:=+25; + position[4].x:=-25; + position[4].y:=-25; + position[4].z:=+25; + position[5].x:=0; + position[5].z:=0; + position[5].y:=-25; + end; + with cube[3] do + begin + position[1].x:=-25; + position[1].y:=+25; + position[1].z:=+25; + position[2].x:=+25; + position[2].y:=+25; + position[2].z:=+25; + position[3].x:=+25; + position[3].y:=+25; + position[3].z:=-25; + position[4].x:=-25; + position[4].y:=+25; + position[4].z:=-25; + position[5].x:=0; + position[5].z:=0; + position[5].y:=25; + end; + with cube[4] do + begin + position[1].x:=-25; + position[1].y:=-25; + position[1].z:=-25; + position[2].x:=-25; + position[2].y:=-25; + position[2].z:=+25; + position[3].x:=-25; + position[3].y:=+25; + position[3].z:=+25; + position[4].x:=-25; + position[4].y:=+25; + position[4].z:=-25; + position[5].y:=0; + position[5].z:=0; + position[5].x:=-25; + end; + with cube[5] do + begin + position[1].x:=+25; + position[1].y:=-25; + position[1].z:=+25; + position[2].x:=+25; + position[2].y:=-25; + position[2].z:=-25; + position[3].x:=+25; + position[3].y:=+25; + position[3].z:=-25; + position[4].x:=+25; + position[4].y:=+25; + position[4].z:=+25; + position[5].x:=25; + position[5].y:=0; + position[5].z:=0; + end; + with cube[6] do + begin + position[1].x:=-25; + position[1].y:=+25; + position[1].z:=-25; + position[2].x:=+25; + position[2].y:=+25; + position[2].z:=-25; + position[3].x:=+25; + position[3].y:=-25; + position[3].z:=-25; + position[4].x:=-25; + position[4].y:=-25; + position[4].z:=-25; + position[5].x:=0; + position[5].y:=0; + position[5].z:=-25; + end; +end; + +begin + init; + repeat + display_cube(1); + repeat + c:=conin; + until(upcase(c)in['E','Q','S','W','D','A','J','K','L','U','I','O'])or(c=#27); + display_cube(0); + case upcase(c) of + 'E':rotz(0); + 'Q':rotz(1); + 'S':rotx(0); + 'W':rotx(1); + 'D':roty(0); + 'A':roty(1); + 'J':begin rotx(1);roty(1);rotz(1);end; + 'L':begin rotx(0);roty(0);rotz(0);end; + 'K':begin rotx(1);roty(0);rotz(1);end; + 'I':begin rotx(0);roty(1);rotz(0);end; + 'U':begin rotx(0);roty(1);rotz(1);end; + 'O':begin rotx(1);roty(0);rotz(0);end; + end; + until c=#27; +end. diff --git a/examples/LICENSES.md b/examples/LICENSES.md new file mode 100644 index 0000000..32ad7df --- /dev/null +++ b/examples/LICENSES.md @@ -0,0 +1,8 @@ +# Attributions for included media files +* ara.pict: Tuxyso / Wikimedia Commons / CC-BY-SA-3.0 +https://commons.wikimedia.org/wiki/File:Ara-Zoo-Muenster-2013.jpg +* snow_leopard.pict: Tambako The Jaguar, CC BY-SA 2.0 , 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/graph1.pas b/examples/graph1.pas new file mode 100644 index 0000000..a1054aa --- /dev/null +++ b/examples/graph1.pas @@ -0,0 +1,19 @@ +{ program 4.9 + graphic representation of a function + f(x) = exp(-x) * sin(2*pi*x) } + +program graph1; +const d = 0.0625; {1/16, 16 lines for interval [x,x+1]} + s = 32; {32 character widths for interval [y,y+1]} + h = 34; {character position of x-axis} + c = 6.28318; {2*pi} lim = 32; +var x,y : real; i,n : integer; +begin + for i := 0 to lim do + begin x := d*i; y := exp(-x)*sin(c*x); + n := round(s*y) + h; + repeat write(' '); n := n-1 + until n=0; + writeln('*') + end +end. 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/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/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..59ff2a7 --- /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 <> #9) 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..cd62b08 --- /dev/null +++ b/pcomp/make.bat @@ -0,0 +1,34 @@ +fpc -Mobjfpc -gl pcomp.pas +fpc -gl sasm.pas +fpc -gl lsymgen.pas + +sasm ..\lib\coreloader.s +lsymgen ..\lib\coreloader.sym +py pcomp.py -n stdlib.pas +libgen ..\lib\stdlib.s +libgen ..\lib\runtime.s +libgen ..\lib\float32.s + +py pcomp.py sasm.pas +py pcomp.py pcomp.pas +py pcomp.py lsymgen.pas +py pcomp.py libgen.pas + +rem exit /b + +py pcomp.py ..\progs\shell.pas +py pcomp.py ..\progs\editor.pas +py pcomp.py ..\progs\reclaim.pas +py pcomp.py ..\progs\dumpdir.pas +py pcomp.py ..\progs\partmgr.pas +py pcomp.py ..\progs\xfer.pas + +rem exit /b + +py pcomp.py ..\tests\readtest.pas +py pcomp.py ..\tests\readchartest.pas +py pcomp.py ..\tests\timetest.pas +py pcomp.py ..\tests\test133.pas +py pcomp.py ..\tests\chase.pas +py pcomp.py ..\tests\cchangetest.pas +py pcomp.py ..\tests\tree.pas 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/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.zip b/tridoraemu.zip new file mode 100644 index 0000000..69fe822 Binary files /dev/null and b/tridoraemu.zip differ 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..60baa42 --- /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, WezTerm and xterm. + +The color scheme in the editor is meant for a dark terminal background. + +The runtime system expects the Backspace key to send the DEL character (ASCII 127). + +## Stopping the emulator +To stop the emulator, close the VGA framebuffer window. +The emulator will also stop if it encounters an infinite loop (a BRANCH @+0 instruction). + +## Things to try out +On the ROM monitor prompt, press *B* to boot from the SD-card image. This should boot into the shell, which will first require you to enter the current date and time. + +In the shell, try the *L* command to list directories and the *V* command to change volumes. The *Example* volume contains some example programs in source form. + +The programs *lines*, *conway* and *mandelbrot*, among others, show some (hopefully) interesting VGA graphics. The *viewpict* program can show image files (*.pict files) which contain 640x400x4 bitmaps. A few sample image files are provided. + +To compile a program, set the file name (e.g. *lines.pas*) with the *W* command in the shell. Then, use *B* and *R* to build and run the program. + +To edit the source file, have the name set with *W* and then use the *E* shell command. Inside the editor, press F1 for the help screen (and RETURN to leave the help screen). Control-X exits the editor, abandoning any changes. + +The volume *Testvolume 1* (note the space) contains a precompiled game called *chase*. This is a game that was written for UCSD Pascal around 1980, and compiles with a few lines of changes with the Tridora Pascal compiler. The source code is also provided on that volume. + +You can run the program with the *O* command in the shell (just press Return for the program arguments), or you can set the workfile name with *W* and then use the *R* command. + +The *K* command in the shell is used to reclaim the space occupied by deleted or overwritten files. + +A running program can be terminated by pressing Control-C, but only if the program is expecting keyboard input at that time. 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..a3a92ab --- /dev/null +++ b/tridoraemu/framebuffer.go @@ -0,0 +1,131 @@ +// Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details +package main + +import ( + // "fmt" + "image/color" + "github.com/hajimehoshi/ebiten/v2" +) + +const VmemWords = 32768 +const PaletteSlots = 16 +const FB_RA = 0 +const FB_WA = 1 +const FB_IO = 2 +const FB_PS = 3 +const FB_PD = 4 +const FB_CTL= 5 + +const PixelMask = 0b11110000000000000000000000000000 +const PixelPerWord = 8 +const VmemWidth = 32 +const BitsPerPixel = 4 +const ScreenWidth = 640 +const ScreenHeight = 400 +const WordsPerLine = ScreenWidth / PixelPerWord + +type Framebuffer struct { + framebuffer *ebiten.Image + palette [PaletteSlots] color.Color + readAddr word + writeAddr word + paletteSlot word + vmem [VmemWords]word + readCount int +} + +func (f *Framebuffer) initialize() { + f.framebuffer = ebiten.NewImage(ScreenWidth, ScreenHeight) + for i := 0; i > (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/go.sum b/tridoraemu/go.sum new file mode 100644 index 0000000..1d4f3bf --- /dev/null +++ b/tridoraemu/go.sum @@ -0,0 +1,96 @@ +atomicgo.dev/keyboard v0.2.9 h1:tOsIid3nlPLZ3lwgG8KZMp/SFmr7P0ssEN5JUsm78K8= +atomicgo.dev/keyboard v0.2.9/go.mod h1:BC4w9g00XkxH/f1HXhW2sXmJFOCWbKn9xrOunSFtExQ= +github.com/MarvinJWendt/testza v0.1.0/go.mod h1:7AxNvlfeHP7Z/hDQ5JtE3OKYT3XFUeLCDE2DQninSqs= +github.com/MarvinJWendt/testza v0.2.1/go.mod h1:God7bhG8n6uQxwdScay+gjm9/LnO4D3kkcZX4hv9Rp8= +github.com/MarvinJWendt/testza v0.2.8/go.mod h1:nwIcjmr0Zz+Rcwfh3/4UhBp7ePKVhuBExvZqnKYWlII= +github.com/MarvinJWendt/testza v0.2.10/go.mod h1:pd+VWsoGUiFtq+hRKSU1Bktnn+DMCSrDrXDpX2bG66k= +github.com/MarvinJWendt/testza v0.2.12/go.mod h1:JOIegYyV7rX+7VZ9r77L/eH6CfJHHzXjB69adAhzZkI= +github.com/MarvinJWendt/testza v0.3.0/go.mod h1:eFcL4I0idjtIx8P9C6KkAuLgATNKpX4/2oUqKc6bF2c= +github.com/MarvinJWendt/testza v0.4.2/go.mod h1:mSdhXiKH8sg/gQehJ63bINcCKp7RtYewEjXsvsVUPbE= +github.com/atomicgo/cursor v0.0.1/go.mod h1:cBON2QmmrysudxNBFthvMtN32r3jxVRIvzkUiF/RuIk= +github.com/containerd/console v1.0.3 h1:lIr7SlA5PxZyMV30bDW0MGbiOPXwc63yRuCP0ARubLw= +github.com/containerd/console v1.0.3/go.mod h1:7LqA/THxQ86k76b8c/EMSiaJ3h1eZkMkXar0TQ1gf3U= +github.com/davecgh/go-spew v1.1.0/go.mod h1:J7Y8YcW2NihsgmVo/mv3lAwl/skON4iLHjSsI+c5H38= +github.com/davecgh/go-spew v1.1.1/go.mod h1:J7Y8YcW2NihsgmVo/mv3lAwl/skON4iLHjSsI+c5H38= +github.com/ebitengine/gomobile v0.0.0-20240518074828-e86332849895 h1:48bCqKTuD7Z0UovDfvpCn7wZ0GUZ+yosIteNDthn3FU= +github.com/ebitengine/gomobile v0.0.0-20240518074828-e86332849895/go.mod h1:XZdLv05c5hOZm3fM2NlJ92FyEZjnslcMcNRrhxs8+8M= +github.com/ebitengine/hideconsole v1.0.0 h1:5J4U0kXF+pv/DhiXt5/lTz0eO5ogJ1iXb8Yj1yReDqE= +github.com/ebitengine/hideconsole v1.0.0/go.mod h1:hTTBTvVYWKBuxPr7peweneWdkUwEuHuB3C1R/ielR1A= +github.com/ebitengine/purego v0.7.0 h1:HPZpl61edMGCEW6XK2nsR6+7AnJ3unUxpTZBkkIXnMc= +github.com/ebitengine/purego v0.7.0/go.mod h1:ah1In8AOtksoNK6yk5z1HTJeUkC1Ez4Wk2idgGslMwQ= +github.com/eiannone/keyboard v0.0.0-20220611211555-0d226195f203 h1:XBBHcIb256gUJtLmY22n99HaZTz+r2Z51xUPi01m3wg= +github.com/eiannone/keyboard v0.0.0-20220611211555-0d226195f203/go.mod h1:E1jcSv8FaEny+OP/5k9UxZVw9YFWGj7eI4KR/iOBqCg= +github.com/faiface/glhf v0.0.0-20211013000516-57b20770c369 h1:gv4BgP50atccdK/1tZHDyP6rMwiiutR2HPreR/OyLzI= +github.com/faiface/glhf v0.0.0-20211013000516-57b20770c369/go.mod h1:dDdUO+G9ZnJ9sc8nIUvhLkE45k8PEKW6+A3TdWsfpV0= +github.com/faiface/mainthread v0.0.0-20171120011319-8b78f0a41ae3 h1:baVdMKlASEHrj19iqjARrPbaRisD7EuZEVJj6ZMLl1Q= +github.com/faiface/mainthread v0.0.0-20171120011319-8b78f0a41ae3/go.mod h1:VEPNJUlxl5KdWjDvz6Q1l+rJlxF2i6xqDeGuGAxa87M= +github.com/go-gl/gl v0.0.0-20210905235341-f7a045908259/go.mod h1:wjpnOv6ONl2SuJSxqCPVaPZibGFdSci9HFocT9qtVYM= +github.com/go-gl/gl v0.0.0-20211210172815-726fda9656d6 h1:zDw5v7qm4yH7N8C8uWd+8Ii9rROdgWxQuGoJ9WDXxfk= +github.com/go-gl/gl v0.0.0-20211210172815-726fda9656d6/go.mod h1:9YTyiznxEY1fVinfM7RvRcjRHbw2xLBJ3AAGIT0I4Nw= +github.com/go-gl/glfw v0.0.0-20210727001814-0db043d8d5be/go.mod h1:vR7hzQXu2zJy9AVAgeJqvqgH9Q5CA+iKCZ2gyEVpxRU= +github.com/go-gl/glfw/v3.3/glfw v0.0.0-20221017161538-93cebf72946b h1:GgabKamyOYguHqHjSkDACcgoPIz3w0Dis/zJ1wyHHHU= +github.com/go-gl/glfw/v3.3/glfw v0.0.0-20221017161538-93cebf72946b/go.mod h1:tQ2UAYgL5IevRw8kRxooKSPJfGvJ9fJQFa0TUsXzTg8= +github.com/go-gl/mathgl v1.0.0/go.mod h1:yhpkQzEiH9yPyxDUGzkmgScbaBVlhC06qodikEM0ZwQ= +github.com/go-gl/mathgl v1.1.0 h1:0lzZ+rntPX3/oGrDzYGdowSLC2ky8Osirvf5uAwfIEA= +github.com/go-gl/mathgl v1.1.0/go.mod h1:yhpkQzEiH9yPyxDUGzkmgScbaBVlhC06qodikEM0ZwQ= +github.com/gookit/color v1.4.2/go.mod h1:fqRyamkC1W8uxl+lxCQxOT09l/vYfZ+QeiX3rKQHCoQ= +github.com/gookit/color v1.5.0/go.mod h1:43aQb+Zerm/BWh2GnrgOQm7ffz7tvQXEKV6BFMl7wAo= +github.com/gopxl/pixel v1.0.0 h1:ZON6ll6/tI6sO8fwrlj93GVUcXReTST5//iKv6lcd8g= +github.com/gopxl/pixel v1.0.0/go.mod h1:kPUBG2He7/+alwmi5z0IwnpAc6pw2N7eA08cdBfoE/Q= +github.com/hajimehoshi/ebiten/v2 v2.7.8 h1:QrlvF2byCzMuDsbxFReJkOCbM3O2z1H/NKQaGcA8PKk= +github.com/hajimehoshi/ebiten/v2 v2.7.8/go.mod h1:Ulbq5xDmdx47P24EJ+Mb31Zps7vQq+guieG9mghQUaA= +github.com/jezek/xgb v1.1.1 h1:bE/r8ZZtSv7l9gk6nU0mYx51aXrvnyb44892TwSaqS4= +github.com/jezek/xgb v1.1.1/go.mod h1:nrhwO0FX/enq75I7Y7G8iN1ubpSGZEiA3v9e9GyRFlk= +github.com/klauspost/cpuid/v2 v2.0.9/go.mod h1:FInQzS24/EEf25PyTYn52gqo7WaD8xa0213Md/qVLRg= +github.com/klauspost/cpuid/v2 v2.0.10/go.mod h1:g2LTdtYhdyuGPqyWyv7qRAmj1WBqxuObKfj5c0PQa7c= +github.com/klauspost/cpuid/v2 v2.0.12/go.mod h1:g2LTdtYhdyuGPqyWyv7qRAmj1WBqxuObKfj5c0PQa7c= +github.com/kr/pretty v0.1.0/go.mod h1:dAy3ld7l9f0ibDNOQOHHMYYIIbhfbHSm3C4ZsoJORNo= +github.com/kr/pty v1.1.1/go.mod h1:pFQYn66WHrOpPYNljwOMqo10TkYh1fy3cYio2l3bCsQ= +github.com/kr/text v0.1.0/go.mod h1:4Jbv+DJW3UT/LiOwJeYQe1efqtUx/iVham/4vfdArNI= +github.com/mattn/go-runewidth v0.0.9 h1:Lm995f3rfxdpd6TSmuVCHVb/QhupuXlYr8sCI/QdE+0= +github.com/mattn/go-runewidth v0.0.9/go.mod h1:H031xJmbD/WCDINGzjvQ9THkh0rPKHF+m2gUSrubnMI= +github.com/mattn/go-runewidth v0.0.13/go.mod h1:Jdepj2loyihRzMpdS35Xk/zdY8IAYHsh153qUoGf23w= +github.com/nsf/termbox-go v1.1.1 h1:nksUPLCb73Q++DwbYUBEglYBRPZyoXJdrj5L+TkjyZY= +github.com/nsf/termbox-go v1.1.1/go.mod h1:T0cTdVuOwf7pHQNtfhnEbzHbcNyCEcVU4YPpouCbVxo= +github.com/pkg/errors v0.9.1 h1:FEBLx1zS214owpjy7qsBeixbURkuhQAwrK5UwLGTwt4= +github.com/pkg/errors v0.9.1/go.mod h1:bwawxfHBFNV+L2hUp1rHADufV3IMtnDRdf1r5NINEl0= +github.com/pmezard/go-difflib v1.0.0/go.mod h1:iKH77koFhYxTK1pcRnkKkqfTogsbg7gZNVY4sRDYZ/4= +github.com/pterm/pterm v0.12.27/go.mod h1:PhQ89w4i95rhgE+xedAoqous6K9X+r6aSOI2eFF7DZI= +github.com/pterm/pterm v0.12.29/go.mod h1:WI3qxgvoQFFGKGjGnJR849gU0TsEOvKn5Q8LlY1U7lg= +github.com/pterm/pterm v0.12.30/go.mod h1:MOqLIyMOgmTDz9yorcYbcw+HsgoZo3BQfg2wtl3HEFE= +github.com/pterm/pterm v0.12.31/go.mod h1:32ZAWZVXD7ZfG0s8qqHXePte42kdz8ECtRyEejaWgXU= +github.com/pterm/pterm v0.12.33/go.mod h1:x+h2uL+n7CP/rel9+bImHD5lF3nM9vJj80k9ybiiTTE= +github.com/pterm/pterm v0.12.36/go.mod h1:NjiL09hFhT/vWjQHSj1athJpx6H8cjpHXNAK5bUw8T8= +github.com/pterm/pterm v0.12.40/go.mod h1:ffwPLwlbXxP+rxT0GsgDTzS3y3rmpAO1NMjUkGTYf8s= +github.com/rivo/uniseg v0.2.0/go.mod h1:J6wj4VEh+S6ZtnVlnTBMWIodfgj8LQOQFoIToxlJtxc= +github.com/sergi/go-diff v1.2.0/go.mod h1:STckp+ISIX8hZLjrqAeVduY0gWCT9IjLuqbuNXdaHfM= +github.com/stretchr/objx v0.1.0/go.mod h1:HFkY916IF+rwdDfMAkV7OtwuqBVzrE8GR6GFx+wExME= +github.com/stretchr/testify v1.4.0/go.mod h1:j7eGeouHqKxXV5pUuKE4zz7dFj8WfuZ+81PSLYec5m4= +github.com/stretchr/testify v1.6.1/go.mod h1:6Fq8oRcR53rry900zMqJjRRixrwX3KX962/h/Wwjteg= +github.com/stretchr/testify v1.7.0/go.mod h1:6Fq8oRcR53rry900zMqJjRRixrwX3KX962/h/Wwjteg= +github.com/xo/terminfo v0.0.0-20210125001918-ca9a967f8778/go.mod h1:2MuV+tbUrU1zIOPMxZ5EncGwgmMJsa+9ucAQZXxsObs= +golang.org/x/image v0.0.0-20190321063152-3fc05d484e9f/go.mod h1:kZ7UVZpmo3dzQBMxlp+ypCbDeSB+sBbTgSJuh5dn5js= +golang.org/x/image v0.18.0 h1:jGzIakQa/ZXI1I0Fxvaa9W7yP25TqT6cHIHn+6CqvSQ= +golang.org/x/image v0.18.0/go.mod h1:4yyo5vMFQjVjUcVk4jEQcU9MGy/rulF5WvUILseCM2E= +golang.org/x/sync v0.7.0 h1:YsImfSBoP9QPYL0xyKJPq0gcaJdG3rInoqxTWbfQu9M= +golang.org/x/sync v0.7.0/go.mod h1:Czt+wKu1gCyEFDUtn0jG5QVvpJ6rzVqr5aXyt9drQfk= +golang.org/x/sys v0.0.0-20201119102817-f84b799fce68/go.mod h1:h1NjWce9XRLGQEsW7wpKNCjG9DtNlClVuFLEZdDNbEs= +golang.org/x/sys v0.0.0-20210124154548-22da62e12c0c/go.mod h1:h1NjWce9XRLGQEsW7wpKNCjG9DtNlClVuFLEZdDNbEs= +golang.org/x/sys v0.0.0-20210330210617-4fbd30eecc44/go.mod h1:h1NjWce9XRLGQEsW7wpKNCjG9DtNlClVuFLEZdDNbEs= +golang.org/x/sys v0.0.0-20210615035016-665e8c7367d1/go.mod h1:oPkhp1MJrh7nUepCBck5+mAzfO9JrbApNNgaTdGDITg= +golang.org/x/sys v0.0.0-20211013075003-97ac67df715c/go.mod h1:oPkhp1MJrh7nUepCBck5+mAzfO9JrbApNNgaTdGDITg= +golang.org/x/sys v0.0.0-20220319134239-a9b59b0215f8/go.mod h1:oPkhp1MJrh7nUepCBck5+mAzfO9JrbApNNgaTdGDITg= +golang.org/x/sys v0.22.0 h1:RI27ohtqKCnwULzJLqkv897zojh5/DwS/ENaMzUOaWI= +golang.org/x/sys v0.22.0/go.mod h1:/VUhepiaJMQUp4+oa/7Zr1D23ma6VTLIYjOOTFZPUcA= +golang.org/x/term v0.0.0-20210220032956-6a3ed077a48d/go.mod h1:bj7SfCRtBDWHUb9snDiAeCFNEtKQo2Wmx5Cou7ajbmo= +golang.org/x/term v0.0.0-20210615171337-6886f2dfbf5b/go.mod h1:jbD1KX2456YbFQfuXm/mYQcufACuNUgVhRMnK/tPxf8= +golang.org/x/term v0.0.0-20210927222741-03fcf44c2211/go.mod h1:jbD1KX2456YbFQfuXm/mYQcufACuNUgVhRMnK/tPxf8= +golang.org/x/term v0.22.0 h1:BbsgPEJULsl2fV/AT3v15Mjva5yXKQDyKf+TbDz7QJk= +golang.org/x/term v0.22.0/go.mod h1:F3qCibpT5AMpCRfhfT53vVJwhLtIVHhB9XDjfFvnMI4= +golang.org/x/text v0.3.0/go.mod h1:NqM8EUOU14njkJ3fqMW+pc6Ldnwhi/IjpwHt7yyuwOQ= +gopkg.in/check.v1 v0.0.0-20161208181325-20d25e280405/go.mod h1:Co6ibVJAznAaIkqp8huTwlJQCZ016jof/cbN4VW5Yz0= +gopkg.in/check.v1 v1.0.0-20190902080502-41f04d3bba15/go.mod h1:Co6ibVJAznAaIkqp8huTwlJQCZ016jof/cbN4VW5Yz0= +gopkg.in/yaml.v2 v2.2.2/go.mod h1:hI93XBmqTisBFMUTm0b8Fm+jr3Dg1NNxqwp+5A1VGuI= +gopkg.in/yaml.v2 v2.2.4/go.mod h1:hI93XBmqTisBFMUTm0b8Fm+jr3Dg1NNxqwp+5A1VGuI= +gopkg.in/yaml.v3 v3.0.0-20200313102051-9f266ea9e77c/go.mod h1:K4uyk7z7BCEPqu6E+C64Yfv1cQ7kz7rIZviUmN+EgEM= +gopkg.in/yaml.v3 v3.0.0-20210107192922-496545a6307b/go.mod h1:K4uyk7z7BCEPqu6E+C64Yfv1cQ7kz7rIZviUmN+EgEM= 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..f635e4b --- /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("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)