From b3a7acb5f5b50375438f0ba68ba14f29ca7faaaa Mon Sep 17 00:00:00 2001 From: nakst <> Date: Fri, 13 Aug 2021 17:18:25 +0100 Subject: [PATCH] hide email --- LICENSE | 21 + README.md | 2 + boot.s | 270 +++ build.sh | 29 + mandelbrot.lisp | 40 + mkfs.c | 120 ++ snake.lisp | 230 +++ startup.lisp | 15 + system.s | 5079 +++++++++++++++++++++++++++++++++++++++++++++++ 9 files changed, 5806 insertions(+) create mode 100644 LICENSE create mode 100644 README.md create mode 100644 boot.s create mode 100644 build.sh create mode 100644 mandelbrot.lisp create mode 100644 mkfs.c create mode 100644 snake.lisp create mode 100644 startup.lisp create mode 100644 system.s diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..96d58f9 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2020 Nakst + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 index 0000000..e17ffdd --- /dev/null +++ b/README.md @@ -0,0 +1,2 @@ +# flip +16-bit Lisp based OS diff --git a/boot.s b/boot.s new file mode 100644 index 0000000..125fb4b --- /dev/null +++ b/boot.s @@ -0,0 +1,270 @@ +[bits 16] +[org 0x7C00] +[cpu 386] + +; Memory map: +; 0x500-0x700: filesystem header +; 0x700-0x900: sector table buffer +; 0x900-0xB00: file sector buffer +; 0x7000-0x7C00: stack +; 0x7C00-0x7E00: this code +; 0x10000-0x20000: loaded program + +start: + ; Setup segment registers and the stack. + cli + xor ax,ax + mov ds,ax + mov ss,ax + mov sp,0x7C00 ; Put stack below the code. + sti + cld + jmp 0x0000:.set_cs + .set_cs: + + ; Save the BIOS drive number. + mov [drive_number],dl + + ; Print a loading message. + mov si,loading_message + call print_string + + ; Get drive parameters. + mov ah,0x08 + mov dl,[drive_number] + xor di,di + int 0x13 + mov si,error_read + jc error + and cx,31 + mov [max_sectors],cx + inc dh + shr dx,8 + mov [max_heads],dx + + ; Load the filesystem header. + xor ax,ax + mov es,ax + mov di,1 + mov bx,0x500 + call load_sector + + ; Check for correct signature and version. + mov si,error_disk + mov ax,[0x500] + cmp ax,0x706C + jne error + mov ax,[0x502] + cmp ax,1 + jne error + + ; Load the root directory. + mov ax,[0x51C] + mov [file_remaining_size],ax + mov ax,[0x520] + mov [current_sector],ax + mov di,ax + xor ax,ax + mov es,ax + mov bx,0x900 + call load_sector + + ; Scan the root directory. + xor bx,bx + .scan_root_directory: + cmp bx,0x200 + jne .loaded_sector + call next_file_sector + xor bx,bx + .loaded_sector: + + ; Compare file name. + xor ax,ax + mov es,ax + mov cx,7 + mov si,program_name + mov di,0x900 + add di,bx + rep cmpsb + jne .next_entry + + ; Save the startup program's first sector, size and checksum. + mov al,[0x917 + bx] + mov [checksum],al + mov ax,[0x910 + bx] + mov [file_remaining_size],ax + mov di,[0x914 + bx] + mov [current_sector],di + jmp .load_startup_program + + ; Go to the next entry. + .next_entry: + add bx,0x20 + sub word [file_remaining_size],0x20 + cmp word [file_remaining_size],0 + jne .scan_root_directory + mov si,error_disk + jmp error + + ; Load the startup program. + .load_startup_program: + xor bx,bx + mov es,bx + mov bx,0x900 + call load_sector + + ; Copy the sector to the destination. + .copy_sector: + mov bx,0x1000 + mov es,bx + mov di,[file_destination] + mov si,0x900 + mov cx,0x200 + rep movsb + + ; Calculate checksum. + mov bl,[checksum] + mov si,0x900 + mov cx,0x200 + .checksum_loop: + lodsb + xor bl,al + loop .checksum_loop + mov [checksum],bl + + ; Load the next sector of the startup program. + add word [file_destination],0x200 + mov ax,[file_remaining_size] + cmp ax,0x200 + jbe .launch + + sub word [file_remaining_size],0x200 + call next_file_sector + jmp .copy_sector + + ; Launch the startup program. + .launch: + mov si,error_disk + cmp byte [checksum],0 + jne error + mov dl,[drive_number] + jmp 0x1000:0x0000 + +next_file_sector: + ; Do we need to switch the sector table buffer? + mov ax,[current_sector] + shr ax,8 ; 256 sector table entries per sector + cmp al,[current_sector_table] + je .skip_switch + mov [current_sector_table],al + + ; Load the new sector table buffer. + add ax,2 + mov di,ax + xor bx,bx + mov es,bx + mov bx,0x700 + call load_sector + .skip_switch: + + ; Get the next sector. + mov bx,[current_sector] + and bx,0xFF + shl bx,1 + mov di,[0x700 + bx] + mov [current_sector],di + + ; Load the next sector. + xor bx,bx + mov es,bx + mov bx,0x900 + jmp load_sector + +; di - LBA. +; es:bx - buffer +load_sector: + mov byte [read_attempts],5 + + .try_again: + + mov si,error_read + mov al,[read_attempts] + or al,al + jz error + dec byte [read_attempts] + + ; Calculate cylinder and head. + mov ax,di + xor dx,dx + div word [max_sectors] + xor dx,dx + div word [max_heads] + push dx ; remainder - head + mov ch,al ; quotient - cylinder + shl ah,6 + mov cl,ah + + ; Calculate sector. + mov ax,di + xor dx,dx + div word [max_sectors] + inc dx + or cl,dl + + ; Load the sector. + pop dx + mov dh,dl + mov dl,[drive_number] + mov ax,0x0201 + int 0x13 + jc .try_again + + ret + +; ds:si - zero-terminated string. +error: + call print_string + jmp $ + +; ds:si - zero-terminated string. +print_string: + lodsb + or al,al + jz .done + mov ah,0xE + int 0x10 + jmp print_string + .done: ret + +file_destination: + dw 0 +current_sector_table: + db 0xFF + +error_read: + db "Cannot read boot disk.",0 +error_disk: + db "Corrupt boot disk.",0 +program_name: + db "system",0 ; don't forget to change name length in comparison! +loading_message: + db 'Loading... ',0 + +times (0x1FE - $ + $$) nop +dw 0xAA55 + +; Uninitialised variables outside the boot image. +drive_number: + db 0 +read_attempts: + db 0 +max_sectors: + dw 0 +max_heads: + dw 0 +current_sector: + dw 0 +file_remaining_size: + dw 0 +checksum: + db 0 diff --git a/build.sh b/build.sh new file mode 100644 index 0000000..ce996e1 --- /dev/null +++ b/build.sh @@ -0,0 +1,29 @@ +mkdir -p bin bin/dest +set -e + +# Create a blank floppy image. +dd if=/dev/zero of=bin/drive.img bs=512 count=2880 status=none + +# Assemble and copy the bootloader. +nasm boot.s -f bin -o bin/boot +dd if=bin/boot of=bin/drive.img bs=512 count=1 conv=notrunc status=none + +# Assemble the system. +nasm system.s -f bin -o bin/dest/system + +# Check the system fits in 32KB. +# The bootloader can't load files greater than a 64KB segment, +# and the system uses the upper 32KB of its segment for buffers. +if [ $(wc -c +#include +#include +#include +#include +#include +#include + +#define HEADER_SIGNATURE (0x706C) +#define VERSION (1) +#define FLAG_DIRECTORY (1 << 0) +#define NAME_SIZE (16) +#define SECTOR_SIZE (0x200) +#define SECTOR_FREE (0) +#define SECTOR_EOF (1) + +typedef uint16_t SectorEntry; + +typedef struct { + /* 00 */ char name[NAME_SIZE]; + /* 16 */ uint32_t fileSize; + /* 20 */ uint16_t firstSector; + /* 22 */ uint8_t flags; + /* 23 */ uint8_t checksum; + /* 24 */ uint8_t unused1[8]; + // 32 bytes. +} DirectoryEntry; + +typedef struct { + // Stored in LBA 1. + /* 00 */ uint16_t signature; + /* 02 */ uint16_t version; + /* 04 */ uint16_t sectorCount; + /* 06 */ uint16_t unused0; + /* 08 */ uint16_t sectorTableSize; // In sectors, starting at LBA 2. + /* 10 */ uint16_t unused1; + /* 12 */ DirectoryEntry root; + // 44 bytes. + uint8_t unused2[512 - 44]; +} Header; + +int main(int argc, char **argv) { + FILE *drive = fopen(argv[1], "r+b"); + + Header header = { HEADER_SIGNATURE }; + header.version = VERSION; + header.sectorCount = atoi(argv[2]); + header.sectorTableSize = header.sectorCount * sizeof(SectorEntry) / SECTOR_SIZE + 1; + + strcpy(header.root.name, "My Floppy"); + header.root.firstSector = 2 + header.sectorTableSize; + + SectorEntry *sectorTable = (SectorEntry *) calloc(SECTOR_SIZE, header.sectorTableSize); + sectorTable[0] = sectorTable[1] = sectorTable[header.root.firstSector] = SECTOR_EOF; + + for (uintptr_t i = 0; i < header.sectorTableSize; i++) { + sectorTable[2 + i] = (i == header.sectorTableSize - 1) ? SECTOR_EOF : (3 + i); + } + + DirectoryEntry *rootDirectory = (DirectoryEntry *) calloc(1, SECTOR_SIZE); + + DIR *import = opendir(argv[3]); + struct dirent *entry; + assert(import); + + int currentSector = header.root.firstSector + 1; + int currentFile = 0; + + while ((entry = readdir(import))) { + // Load the file. + if (entry->d_name[0] == '.') continue; + char buffer[256]; + sprintf(buffer, "%s/%s", argv[3], entry->d_name); + struct stat s; + lstat(buffer, &s); + if (!S_ISREG(s.st_mode)) continue; + FILE *input = fopen(buffer, "rb"); + assert(input); + fseek(input, 0, SEEK_END); + uint64_t fileSize = ftell(input); + fseek(input, 0, SEEK_SET); + void *data = malloc(fileSize); + fread(data, 1, fileSize, input); + fclose(input); + + // Setup the root directory entry. + assert(header.root.fileSize != SECTOR_SIZE); + header.root.fileSize += sizeof(DirectoryEntry); + assert(strlen(entry->d_name) < NAME_SIZE); + strncpy(rootDirectory[currentFile].name, entry->d_name, NAME_SIZE); + rootDirectory[currentFile].fileSize = fileSize; + rootDirectory[currentFile].firstSector = currentSector; + + // Calculate the checksum. + rootDirectory[currentFile].checksum = 0; + for (uintptr_t i = 0; i < fileSize; i++) rootDirectory[currentFile].checksum ^= ((uint8_t *) data)[i]; + + // Write out the file. + int sectorCount = (fileSize + SECTOR_SIZE) / SECTOR_SIZE; + fseek(drive, SECTOR_SIZE * currentSector, SEEK_SET); + fwrite(data, 1, fileSize, drive); + + // Update the sector table. + for (uintptr_t i = currentSector; i < currentSector + sectorCount - 1; i++) sectorTable[i] = i + 1; + sectorTable[currentSector + sectorCount - 1] = SECTOR_EOF; + + // Go to the next file. + // printf("import %d %s of size %d (%d sectors) at sector %d\n", currentFile, buffer, fileSize, sectorCount, currentSector); + currentSector += sectorCount; + currentFile++; + free(data); + } + + fseek(drive, SECTOR_SIZE, SEEK_SET); + fwrite(&header, 1, SECTOR_SIZE, drive); + fwrite(sectorTable, 1, SECTOR_SIZE * header.sectorTableSize, drive); + fwrite(rootDirectory, 1, SECTOR_SIZE, drive); + + return 0; +} diff --git a/snake.lisp b/snake.lisp new file mode 100644 index 0000000..72d3b18 --- /dev/null +++ b/snake.lisp @@ -0,0 +1,230 @@ +[let TILE 16] +[let GRID_X 20] +[let GRID_Y 12] + +[let snake nil] +[let direction nil] +[let direction-id nil] +[let apple nil] +[let game-running nil] +[let score nil] + +[let tile-head-left [q [1 1 1 3 3 3 1 1 1 2 3 4 5 4 3 3 1 3 4 6 5 5 5 5 1 3 4 4 5 5 5 5 1 3 4 4 5 5 5 5 1 3 4 6 5 5 5 5 1 2 3 4 5 4 3 3 1 1 1 3 3 3 1 1]]] +[let tile-head-right [q [1 1 3 3 3 1 1 1 3 3 4 5 4 3 2 1 5 5 5 5 6 4 3 1 5 5 5 5 4 4 3 1 5 5 5 5 4 4 3 1 5 5 5 5 6 4 3 1 3 3 4 5 4 3 2 1 1 1 3 3 3 1 1 1]]] +[let tile-head-down [q [1 3 5 5 5 5 3 1 1 3 5 5 5 5 3 1 3 4 5 5 5 5 4 3 3 5 5 5 5 5 5 3 3 4 6 4 4 6 4 3 1 3 4 4 4 4 3 1 1 2 3 3 3 3 2 1 1 1 1 1 1 1 1 1]]] +[let tile-head-up [q [1 1 1 1 1 1 1 1 1 2 3 3 3 3 2 1 1 3 4 4 4 4 3 1 3 4 6 4 4 6 4 3 3 5 5 5 5 5 5 3 3 4 5 5 5 5 4 3 1 3 5 5 5 5 3 1 1 3 5 5 5 5 3 1]]] +[let tile-tail-left [q [1 1 1 1 1 1 1 1 3 3 2 1 1 2 2 1 5 5 4 3 1 1 2 1 5 5 5 5 4 3 1 1 5 5 5 5 4 3 1 1 5 5 4 3 1 1 2 1 3 3 2 1 1 2 2 1 1 1 1 1 1 1 1 1]]] +[let tile-tail-right [q [1 1 1 1 1 1 1 1 1 2 2 1 1 2 3 3 1 2 1 1 3 4 5 5 1 1 3 4 5 5 5 5 1 1 3 4 5 5 5 5 1 2 1 1 3 4 5 5 1 2 2 1 1 2 3 3 1 1 1 1 1 1 1 1]]] +[let tile-tail-down [q [1 1 1 1 1 1 1 1 1 2 2 1 1 2 2 1 1 2 1 3 3 1 2 1 1 1 1 4 4 1 1 1 1 1 3 5 5 3 1 1 1 2 4 5 5 4 2 1 1 3 5 5 5 5 3 1 1 3 5 5 5 5 3 1]]] +[let tile-tail-up [q [1 3 5 5 5 5 3 1 1 3 5 5 5 5 3 1 1 2 4 5 5 4 2 1 1 1 3 5 5 3 1 1 1 1 1 4 4 1 1 1 1 2 1 3 3 1 2 1 1 2 2 1 1 2 2 1 1 1 1 1 1 1 1 1]]] +[let tile-body-h [q [1 1 1 1 1 1 1 1 3 3 3 1 1 3 3 3 5 5 4 3 3 4 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 4 3 3 4 5 5 3 3 3 1 1 3 3 3 1 1 1 1 1 1 1 1]]] +[let tile-body-v [q [1 3 5 5 5 5 3 1 1 3 5 5 5 5 3 1 1 3 4 5 5 4 3 1 1 1 3 5 5 3 1 1 1 1 3 5 5 3 1 1 1 3 4 5 5 4 3 1 1 3 5 5 5 5 3 1 1 3 5 5 5 5 3 1]]] +[let tile-body-nw [q [1 3 5 5 5 5 3 1 3 4 5 5 5 5 3 1 5 5 5 5 5 5 3 1 5 5 5 5 5 4 3 1 5 5 5 5 4 3 1 1 5 5 5 4 3 1 2 1 3 3 3 3 1 2 2 1 1 1 1 1 1 1 1 1]]] +[let tile-body-ne [q [1 3 5 5 5 5 3 1 1 3 5 5 5 5 4 3 1 3 5 5 5 5 5 5 1 3 4 5 5 5 5 5 1 1 3 4 5 5 5 5 1 2 1 3 4 5 5 5 1 2 2 1 3 3 3 3 1 1 1 1 1 1 1 1]]] +[let tile-body-sw [q [1 1 1 1 1 1 1 1 3 3 3 3 1 2 2 1 5 5 5 4 3 1 2 1 5 5 5 5 4 3 1 1 5 5 5 5 5 4 3 1 5 5 5 5 5 5 3 1 3 4 5 5 5 5 3 1 1 3 5 5 5 5 3 1]]] +[let tile-body-se [q [1 1 1 1 1 1 1 1 1 2 2 1 3 3 3 3 1 2 1 3 4 5 5 5 1 1 3 4 5 5 5 5 1 3 4 5 5 5 5 5 1 3 5 5 5 5 5 5 1 3 5 5 5 5 4 3 1 3 5 5 5 5 3 1]]] +[let tile-background [q [1 1 1 1 1 1 1 1 1 2 2 1 1 2 2 1 1 2 1 1 1 1 2 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 1 1 1 1 2 1 1 2 2 1 1 2 2 1 1 1 1 1 1 1 1 1]]] +[let tile-apple [q [1 1 1 9 1 1 1 1 1 2 2 1 9 2 2 1 1 7 7 7 9 8 8 1 7 7 9 7 7 8 8 8 7 9 9 7 7 8 8 8 7 7 7 7 7 8 8 8 1 7 7 7 7 8 8 1 1 1 7 7 8 8 1 1]]] +[let tile-digit-0 [q [2 2 7 7 7 7 2 2 2 7 7 8 8 7 7 2 2 7 7 8 2 7 7 8 2 7 7 8 7 7 7 8 2 7 7 7 2 7 7 8 2 7 7 8 2 7 7 8 2 7 7 8 2 7 7 8 2 2 7 7 7 7 8 2]]] +[let tile-digit-1 [q [2 2 2 7 7 2 2 2 2 2 7 7 7 8 2 2 2 2 7 7 7 8 2 2 2 2 2 7 7 8 2 2 2 2 2 7 7 8 2 2 2 2 2 7 7 8 2 2 2 2 2 7 7 8 2 2 2 2 2 7 7 8 2 2]]] +[let tile-digit-2 [q [2 2 7 7 7 7 2 2 2 7 7 8 8 7 7 8 2 7 7 8 2 7 7 8 2 2 8 2 2 7 7 8 2 2 7 7 7 7 8 2 2 7 7 8 8 8 2 2 2 7 7 8 2 7 7 2 2 7 7 7 7 7 7 8]]] +[let tile-digit-3 [q [2 2 7 7 7 7 2 2 2 2 2 8 8 7 7 2 2 2 2 2 2 7 7 8 2 2 2 7 7 7 7 8 2 2 2 2 8 7 7 8 2 2 2 2 2 7 7 8 2 2 2 2 2 7 7 8 2 2 7 7 7 7 8 2]]] +[let tile-digit-4 [q [2 2 7 2 2 7 7 2 2 2 7 8 2 7 7 8 2 7 7 8 2 7 7 8 2 7 7 8 2 7 7 8 2 7 7 7 7 7 7 8 2 2 8 8 8 7 7 8 2 2 2 2 2 7 7 8 2 2 2 2 2 7 7 8]]] +[let tile-digit-5 [q [2 2 7 7 7 7 7 2 2 2 7 7 8 8 8 2 2 2 7 7 2 2 2 2 2 2 7 7 7 7 2 2 2 2 2 8 8 7 7 2 2 2 2 2 2 7 7 8 2 2 2 2 2 7 7 8 2 2 7 7 7 7 8 2]]] +[let tile-digit-6 [q [2 2 7 7 7 7 2 2 2 7 7 8 8 7 7 2 2 7 7 2 2 7 7 8 2 7 7 2 2 2 8 8 2 7 7 7 7 7 7 2 2 7 7 8 8 7 7 8 2 7 7 8 2 7 7 8 2 2 7 7 7 7 8 2]]] +[let tile-digit-7 [q [2 7 7 7 7 7 7 2 2 7 7 8 8 7 7 8 2 2 8 2 2 7 7 8 2 2 2 2 2 7 7 8 2 2 2 2 2 7 7 8 2 2 2 2 7 7 8 2 2 2 2 2 7 7 8 2 2 2 2 2 7 7 8 2]]] +[let tile-digit-8 [q [2 2 7 7 7 7 2 2 2 7 7 8 8 7 7 2 2 7 7 8 2 7 7 8 2 2 7 7 7 7 8 2 2 7 7 8 8 7 7 2 2 7 7 8 2 7 7 8 2 7 7 8 2 7 7 8 2 2 7 7 7 7 8 2]]] +[let tile-digit-9 [q [2 2 7 7 7 7 2 2 2 7 7 8 8 7 7 2 2 7 7 8 2 7 7 8 2 2 7 7 7 7 7 8 2 2 2 8 8 7 7 8 2 2 2 2 2 7 7 8 2 7 7 2 2 7 7 8 2 2 7 7 7 7 8 2]]] + +[let tile-digits [list tile-digit-0 tile-digit-1 tile-digit-2 tile-digit-3 tile-digit-4 tile-digit-5 tile-digit-6 tile-digit-7 tile-digit-8 tile-digit-9]] + +[defun tile-overlap [x y] [and [is [car x] [car y]] [is [cdr x] [cdr y]]]] + +[defun draw-tile [x y tile] [do + [let i 0] + [while [< i TILE] [do + [let p [+ [* x TILE] [* [+ i [* y TILE]] 320]]] + [let j 0] + [let ts tile] + [while [< j TILE] [do + [let col [car tile]] + [= tile [cdr tile]] + [poke 10 p col] + [inc j] + [inc p] + [poke 10 p col] + [inc j] + [inc p] + ]] + [inc i] + [= p [+ [* x TILE] [* [+ i [* y TILE]] 320]]] + [= j 0] + [= tile ts] + [while [< j TILE] [do + [let col [car tile]] + [= tile [cdr tile]] + [poke 10 p col] + [inc j] + [inc p] + [poke 10 p col] + [inc j] + [inc p] + ]] + [inc i] + ]] +]] + +[defun draw-apple [] [do + [draw-tile [car apple] [cdr apple] tile-apple] +]] + +[defun draw-snake-body [before pos after] [do + [draw-tile [car pos] [cdr pos] [if + [is [car before] [car after]] tile-body-v + [is [cdr before] [cdr after]] tile-body-h + [and [is [car before] [- [car pos] 1]] [is [cdr after] [- [cdr pos] 1]]] tile-body-nw + [and [is [car after] [- [car pos] 1]] [is [cdr before] [- [cdr pos] 1]]] tile-body-nw + [and [is [car before] [- [car pos] 1]] [is [cdr after] [+ [cdr pos] 1]]] tile-body-sw + [and [is [car after] [- [car pos] 1]] [is [cdr before] [+ [cdr pos] 1]]] tile-body-sw + [and [is [car before] [+ [car pos] 1]] [is [cdr after] [- [cdr pos] 1]]] tile-body-ne + [and [is [car after] [+ [car pos] 1]] [is [cdr before] [- [cdr pos] 1]]] tile-body-ne + tile-body-se + ]] +]] + +[defun draw-snake-head [p] [do + [draw-tile [car p] [cdr p] [if + [is direction-id 0] tile-head-left + [is direction-id 1] tile-head-down + [is direction-id 2] tile-head-right + tile-head-up]] +]] + +[defun draw-snake-tail [before pos] [do + [draw-tile [car pos] [cdr pos] [if + [is [car before] [- [car pos] 1]] tile-tail-left + [is [car before] [+ [car pos] 1]] tile-tail-right + [is [cdr before] [- [cdr pos] 1]] tile-tail-up + tile-tail-down + ]] +]] + +[defun draw-background-piece [p] [do + [draw-tile [car p] [cdr p] tile-background] +]] + +[defun draw-background [] [do + [let i 0] + [while [< i GRID_X] [do + [let j 0] + [while [< j GRID_Y] [do + [draw-background-piece [cons i j]] + [inc j] + ]] + [inc i] + ]] +]] + +[defun move-apple [] [do + [= apple [cons [mod [random] GRID_X] [mod [random] GRID_Y]]] + [inc score] +]] + +[defun wrap [x y] [if [< x 0] -1 [is x y] -1 x]] + +[defun move-snake [] [do + [let head [car snake]] + [let moved-head [cons [wrap [+ [car head] [car direction]] GRID_X] [wrap [+ [cdr head] [cdr direction]] GRID_Y]]] + [= snake [cons moved-head snake]] +]] + +[defun process-input [] [do + [let x [last-scancode]] + [if [is x 72] [do [= direction [cons 0 -1]] [= direction-id 3]] 0] + [if [is x 77] [do [= direction [cons 1 0]] [= direction-id 2]] 0] + [if [is x 80] [do [= direction [cons 0 1]] [= direction-id 1]] 0] + [if [is x 75] [do [= direction [cons -1 0]] [= direction-id 0]] 0] +]] + +[defun game-over [] [do + [if game-running [= game-running nil] 0] +]] + +[defun check-collision [] [do + [let s snake] + [let head [car s]] + [if [or [is [car head] -1] [is [cdr head] -1]] [game-over] 0] + [while s [do + [let t [cdr s]] + [while t [do + [if [tile-overlap [car s] [car t]] + [game-over] 0 + ] + [= t [cdr t]] + ]] + [= s [cdr s]] + ]] +]] + +[defun show-score [] [do + [draw-tile 9 4 [nth tile-digits [mod [/ score 100] 10]]] + [draw-tile 10 4 [nth tile-digits [mod [/ score 10 ] 10]]] + [draw-tile 11 4 [nth tile-digits [mod [/ score 1 ] 10]]] +]] + +[defun set-color [i r g b] [do + [outb 968 i] + [outb 969 r] + [outb 969 g] + [outb 969 b] +]] + +[defun set-palette [] [do + [set-color 1 24 20 20] + [set-color 2 30 25 26] + [set-color 3 27 44 31] + [set-color 4 32 48 31] + [set-color 5 36 52 31] + [set-color 6 12 7 11] + [set-color 7 57 36 29] + [set-color 8 44 23 20] + [set-color 9 56 48 43] +]] + +[defun before-last [x] [if [cdr [cdr x]] [before-last [cdr x]] x]] + +[defun start-game [] [do + [set-graphics 1] + [set-palette] + [= game-running 1] + [= score 0] + [= snake [list [q [8 . 5]] [q [7 . 5]] [q [6 . 5]] [q [5. 5]]]] + [= direction [q [1 . 0]]] + [= direction-id 2] + [draw-background] + [move-apple] + [while game-running [do + [let tail [last snake]] + [draw-background-piece tail] + [move-snake] + [let head [car snake]] + [let body [car [cdr snake]]] + [let body-after [car [cdr [cdr snake]]]] + [draw-snake-body head body body-after] + [draw-snake-head head] + [if [tile-overlap head apple] [move-apple] [del-last snake]] + [let tail-before [before-last snake]] + [draw-snake-tail [car tail-before] [car [cdr tail-before]]] + [draw-apple] + [process-input] + [check-collision] + [pause] + [pause] + ]] + [show-score] + [wait-key] + [set-graphics nil] + [print "Type [start-game] to play again!"] +]] + +[start-game] diff --git a/startup.lisp b/startup.lisp new file mode 100644 index 0000000..5bdac95 --- /dev/null +++ b/startup.lisp @@ -0,0 +1,15 @@ +[let defun [mac [name args body] + [list let name nil] + [list = name [list fun args body]]]] + +[defun square [x] [* x x]] + +[let inc [mac [s] [list [q =] s [list [q +] s 1]]]] + +[defun to-upper [str] [capture-upper [print str]]] +[defun to-lower [str] [capture-lower [print str]]] + +[defun last [x] [if [cdr x] [last [cdr x]] [car x]]] +[defun del-last [x] [if [cdr [cdr x]] [del-last [cdr x]] [setcdr x nil]]] + +[defun nth [a n] [if [is n 0] [car a] [nth [cdr a] [- n 1]]]] diff --git a/system.s b/system.s new file mode 100644 index 0000000..dae5ee7 --- /dev/null +++ b/system.s @@ -0,0 +1,5079 @@ +[bits 16] +[org 0] +[cpu 386] + +; Memory map: +; 0x500-0x8000: all list (SS) +; 0x8000-0x10000: stack (SS) +; 0x10000-0x18000: system code (CS/DS) +; 0x18000-0x20000: system data (DS) +; 0x20000-0x30000: objects (FS) +; 0x30000-0x40000: strings (GS) +; 0x40000-0x50000: environment relinking + +%define ADDITIONAL_DATA (0x8000) +%define INPUT_BUFFER_SIZE (0x200) +%define INPUT_BUFFER (ADDITIONAL_DATA) +%define MAX_OPEN_FILES (8) +%define SECTOR_SIZE (0x200) +%define OPEN_FILE_BUFFER (INPUT_BUFFER + INPUT_BUFFER_SIZE) +%define SECTOR_TABLE_BUFFER (OPEN_FILE_BUFFER + SECTOR_SIZE * MAX_OPEN_FILES) +%define FS_HEADER_BUFFER (SECTOR_TABLE_BUFFER + SECTOR_SIZE) +%define TYPE_BUFFER_SIZE (0x100) +%define TYPE_BUFFER (FS_HEADER_BUFFER + SECTOR_SIZE) +%define PRIOR_INPUT_BUFFER (TYPE_BUFFER + TYPE_BUFFER_SIZE) + +; Standard file open modes: +%define FILE_READ (1) +%define FILE_WRITE (2) +%define FILE_APPEND (3) + +; Special file open modes: +%define FILE_RENAME (4) +%define FILE_DELETE (5) + +; File flags. +%define FILE_ERROR (0x80) + +; 0 position in root directory +; 2 (remaining) file size low +; 4 (remaining) file size high +; 6 offset into sector +; 8 current sector +; 10 access mode (0 if handle unused) +; 11 checksum +%define DATA_PER_OPEN_FILE (12) +%define ROOT_HANDLE ((MAX_OPEN_FILES - 1) * DATA_PER_OPEN_FILE + open_file_table) + +%define SCREEN_COLOR (0x0700) +%define HIGHLIGHT_COLOR (0x1700) +%define ALT_COLOR (0x2F00) +%define ALT2_COLOR (0x3F00) +%define ALT3_COLOR (0x1F00) +%define ERROR_COLOR (0x4F00) + +; If the stack pointer goes below this value then we assume it's about to overflow. +; We need a reasonable margin before the all list begins, +; since the stack is also used by the BIOS's interrupt handlers. +%macro CHECK_STACK_OVERFLOW 0 + cmp sp,0x8200 + jb error_stack_overflow +%endmacro + +; Call the garbage collector before every object/string allocation. +; This is used to ensure that the all list is correct, +; so that only truly inaccessible objects are freed. +; %define ALWAYS_GC + +; The all list is a stack of objects that shouldn't be freed. +; It grows down and uses SS, much like the actual stack. +; Its position is kept in BP, throughout all functions that need it. +; The symbol table is not kept in the all list. +%define ALL_LIST_TOP (0x8000) +%define ALL_POP(x) add bp,2*x + +%macro ALL_PUSH 1 + sub bp,2 + cmp bp,0x500 + je error_stack_overflow + mov [ss:bp],%1 +%endmacro + +; Each object is 4 bytes. Object 0 is nil. +; Bit 0 of the first word is used by the garbage collector. +; Bit 1 of the first word is set if the object is not a pair. +; The first word is used by pairs to store car, otherwise to store the object type. +; The second word stores object data. For pairs, this is cdr. +%define OBJ_SIZE (4) +%define TYPE_FREE (0x06) +%define TYPE_INT (0x0A) +%define TYPE_STRING (0x0E) +%define TYPE_LAMBDA (0x12) +%define TYPE_SYMBOL (0x16) +%define TYPE_BUILTIN (0x1A) +%define TYPE_NIL (0x1E) +%define TYPE_MACRO (0x22) +%define CAR(d,s) mov d,[fs:s + 0] +%define CDR(d,s) mov d,[fs:s + 2] +%define SETCAR(d,s) mov [fs:d + 0],s +%define SETCDR(d,s) mov [fs:d + 2],s + +; Each string section is 8 bytes. Section 0 is used to terminate a string. +; Bit 0 of the first word is used by the garbage collector. +; Bit 1 of the first word is set if the section is unused. +; The first word indicates the identifier of the next section. +; The other words in the section store 6 ASCII characters of the string. +; If the string length is not a multiple of 6, then the last section is padded with 0s. +%define STRING_SIZE (8) +%define STRING_DATA (6) +%define STRING_NEXT(d, s) mov d,[gs:s + 0] +%define MAX_SYMBOL_LENGTH (24) + +%define BUILTIN_NIL (0) + +; Flags for next_argument: +%define NEXT_ARG_ANY (1 << 8) ; Match any type. +%define NEXT_ARG_QUOTE (1 << 9) ; Don't evaluate the argument. +%define NEXT_ARG_FINAL (1 << 10) ; Check this is the last argument. +%define NEXT_ARG_TAIL (1 << 11) ; Tail call evaluate. Implies _ANY and _BX; incompatible with _QUOTE and _KEEP. +%define NEXT_ARG_KEEP (1 << 12) ; Add the result to the all list. +%define NEXT_ARG_BX (1 << 13) ; Return the result in _BX. Use with _FINAL. +%define NEXT_ARG_NIL (1 << 14) ; Allow nil as well as any matched types. + +start: + ; Setup segment registers and the stack. + cli + xor ax,ax + mov ss,ax + mov ax,0x1000 + mov ds,ax + mov ax,0x2000 + mov fs,ax + mov ax,0x3000 + mov gs,ax + mov sp,0 + cld + sti + + ; Save the BIOS drive number. + mov [drive_number],dl + + ; Clear the screen. + call clear_screen + + ; Install exception handlers. + call install_exception_handlers + + ; Initialize IO. + call initialize_io + + ; Initialize the interpreter. + call initialize_interpreter + + ; Run the REPL. + mov word [recover],repl + call repl + + cli + hlt + +repl: + ; Reset stack. + mov sp,0 + + ; Allow the garbage collector to run. + mov byte [gc_ready],1 + + ; Close any open files. + mov cx,MAX_OPEN_FILES - 1 + mov si,open_file_table + .close_file_loop: + cmp byte [si + 10],0 + jz .handle_unused + push si + push cx + call close_file + pop cx + pop si + .handle_unused: + add si,DATA_PER_OPEN_FILE + loop .close_file_loop + + ; Get user input. + mov word [print_callback],terminal_print_string + cmp byte [run_startup_command],0 + je .do_startup + mov si,prompt_message + call print_string + call get_user_input + jmp .got_input + .do_startup: + mov byte [run_startup_command],1 + mov cx,[startup_command_length] + mov si,startup_command + mov ax,ds + mov es,ax + mov di,INPUT_BUFFER + rep movsb + mov word [print_callback],output_null + .got_input: + + ; Reset read information. + mov byte [next_character],0 + mov word [input_line],1 + mov word [input_offset],0 + mov word [input_handle],0 + + ; Set the environment. + cmp word [.environment],0 + jne .environment_set + mov bx,[obj_builtins] + mov [.environment],bx + .environment_set: + + ; Tidy the environment. + mov bx,[.environment] + call tidy_environment + + ; Read and evaluate all the objects in the input buffer. + .evaluate_loop: + mov bp,ALL_LIST_TOP + mov bx,[.environment] + ALL_PUSH(bx) + call print_newline + call read_object + cmp bx,0xFFFF + je .last_object + ALL_PUSH(bx) + mov si,[.environment] + push si + mov di,sp + call evaluate_object + pop si + mov [.environment],si + or bx,bx + jz .evaluate_loop + mov cx,-100 + xor dx,dx + call print_object + jmp .evaluate_loop + .last_object: + or al,al + jne error_unexpected_character + jmp repl + + .environment: dw 0 + +get_user_input: + ; Save the position where user input began. + call get_caret_position + mov [user_input_start],bx + + ; Reset last scancode. + mov byte [last_scancode],0 + + ; Add entropy to RNG. + xor ah,ah + int 0x1A + add [do_builtin_random.seed],dx + add [do_builtin_random.seed],cx + + xor bx,bx + + .loop: + + ; Highlight the first unmatched brace. + push bx + call highlight_first_unmatched_brace + pop bx + + ; Read a character from the keyboard. + xor ax,ax + push bx + int 0x16 + pop bx + cmp ah,0x48 + je .up + cmp al,8 + je .backspace + cmp al,13 + je .done + cmp al,32 + jb .loop + cmp al,127 + jae .loop + + ; Append the character to the end of the buffer. + cmp bx,INPUT_BUFFER_SIZE - 1 + je .loop + mov [INPUT_BUFFER + bx],al + inc bx + + ; Echo the character to the screen. + push ax + push bx + call print_character + pop bx + pop ax + + jmp .loop + + ; Move the caret back. + .backspace: + or bx,bx + jz .loop + push bx + call print_backspace + + ; Clear the cell. + mov al,' ' + call print_character + call print_backspace + pop bx + dec bx + jmp .loop + + ; Copy the prior input buffer to the current input buffer. + .up: + mov ax,ds + mov es,ax + mov di,INPUT_BUFFER + mov si,PRIOR_INPUT_BUFFER + mov cx,INPUT_BUFFER_SIZE + rep movsb + + ; Clear the already typed text. + mov cx,bx + or cx,cx + jz .no_text_to_clear + .clear_loop: + push cx + call print_backspace + mov al,' ' + call print_character + call print_backspace + pop cx + loop .clear_loop + .no_text_to_clear: + + ; Print the new text. + mov si,INPUT_BUFFER + call print_string + + ; Update bx to the length of the new input. + xor bx,bx + mov si,INPUT_BUFFER + .count_loop: + lodsb + or al,al + jz .loop + inc bx + jmp .count_loop + + .done: + + ; Zero terminate the result. + mov byte [INPUT_BUFFER + bx],0 + + ; Copy to the prior input buffer. + mov cx,bx + inc cx + mov ax,ds + mov es,ax + mov di,PRIOR_INPUT_BUFFER + mov si,INPUT_BUFFER + rep movsb + + ; Remove any highlighting on an unmatched brace. + mov bx,[previously_unmatched_brace] + or bx,bx + jz .cleared_old_formatting + mov ax,0xB800 + mov es,ax + mov byte [es:bx],SCREEN_COLOR >> 8 + .cleared_old_formatting: + + ret + +; returns position in bx +; preserves cx, si, di, bp +get_caret_position: + mov ax,[caret_row] + mov dx,160 + mul dx + mov bx,[caret_column] + shl bx,1 + add bx,ax + ret + +; bx - input buffer position +highlight_first_unmatched_brace: + mov ax,0xB800 + mov es,ax + mov cx,bx + + ; Clear the formatting on the previously unmatched brace. + mov bx,[previously_unmatched_brace] + or bx,bx + jz .cleared_old_formatting + mov byte [es:bx],SCREEN_COLOR >> 8 + .cleared_old_formatting: + + ; Find the first unmatched brace. + call get_caret_position + xor cx,cx + .search_loop: + sub bx,2 + cmp bx,[user_input_start] + jb .at_start + mov al,[es:bx] + cmp al,']' + je .right_brace + cmp al,'[' + je .left_brace + jmp .search_loop + .right_brace: + inc cx + jmp .search_loop + .left_brace: + or cx,cx + jz .found + dec cx + jmp .search_loop + + ; Set the formatting for the matching brace. + .found: + inc bx + mov [previously_unmatched_brace],bx + mov byte [es:bx],HIGHLIGHT_COLOR >> 8 + ret + + ; Check if there were more closing braces than opening braces. + .at_start: + or cx,cx + jz .done + + ; Highlight the last unmatched closing brace. + call get_caret_position + .search_loop2: + sub bx,2 + cmp bx,[user_input_start] + jb .done + mov al,[es:bx] + cmp al,']' + jne .search_loop2 + inc bx + mov [previously_unmatched_brace],bx + mov byte [es:bx],ERROR_COLOR >> 8 + ret + + ; All braces were matched. + .done: + xor bx,bx + mov [previously_unmatched_brace],bx + ret + +initialize_interpreter: + ; The first object and string are reserved to indicate nil. + mov ax,1 + mov word [first_free_string],STRING_SIZE + mov word [first_free_object],OBJ_SIZE + + ; Create a list of free strings. + mov cx,(65536 / STRING_SIZE - 1) + mov bx,STRING_SIZE + mov ax,(STRING_SIZE * 2 + 2) + .free_string_loop: + mov [gs:bx],ax + add bx,STRING_SIZE + add ax,STRING_SIZE + loop .free_string_loop + + ; Create a list of free objects. + mov cx,(65536 / OBJ_SIZE - 1) + mov bx,OBJ_SIZE + mov ax,(OBJ_SIZE * 2) + mov dx,TYPE_FREE + .free_obj_loop: + SETCAR(bx, dx) + SETCDR(bx, ax) + add bx,OBJ_SIZE + add ax,OBJ_SIZE + loop .free_obj_loop + + ; Initial the nil object and string. + mov word [gs:0],0 + mov word [gs:2],0 + mov word [gs:4],0 + mov word [gs:6],0 + mov word [fs:0],TYPE_NIL + mov word [fs:2],0 + + ; Start the symbol table and builtins as the nil object. + mov word [obj_symbol_table],0 + mov word [obj_builtins],0 + + ; Add builtins. + call add_builtins + + ret + +add_builtins: + mov si,builtin_strings + mov dx,0 + .builtin_loop: + + ; Check if we're done. + mov al,[si] + or al,al + jz .done + + push si + push dx + + xor bx,bx + cmp dx,BUILTIN_NIL + je .made_object + + ; Make the builtin object itself. + mov ax,TYPE_BUILTIN + call new_object + .made_object: + + ; Get the symbol object. + push bx + mov bp,ALL_LIST_TOP + call find_symbol + + ; Create the pair of symbol-builtin. + mov ax,bx + pop dx + call new_object + + ; Create the list object. + mov ax,bx + mov dx,[obj_builtins] + call new_object + mov [obj_builtins],bx + + ; Advance to the next builtin. + pop dx + pop si + inc dx + .string_end_loop: + lodsb + or al,al + jne .string_end_loop + jmp .builtin_loop + + .done: + ret + +; bp - all list (preserved) +; returns object in bx (bx != 0xFFFF), or character in al (bx = 0xFFFF) +read_object: + CHECK_STACK_OVERFLOW + + ; Read a non-whitespace character. + .try_again: + call read_next_character + cmp al,10 + je .try_again + cmp al,13 + je .try_again + cmp al,9 + je .try_again + cmp al,' ' + je .try_again + + ; End of input? + mov bx,0xFFFF + or al,al + je .done + + ; Check for a comment. + cmp al,';' + jne .not_comment + .comment_loop: + call read_next_character + or al,al + jz read_object + cmp al,10 + je read_object + jmp .comment_loop + .not_comment: + + ; Check for single-character tokens, ']' and '.'. + mov bx,0xFFFF + cmp al,']' + je .done + cmp al,'.' + je .done + + ; Check for string. + cmp al,'"' + je read_string_object + + ; Check for list. + cmp al,'[' + je read_list_object + + ; It must be either a symbol or integer. + jmp read_symbol_object + + .done: + ret + +; bp - all list (preserved) +read_string_object: + ; Create the object. + mov ax,TYPE_STRING + xor dx,dx ; new_string could gc, so this should be valid + call new_object + ALL_PUSH(bx) + + ; Create the first string section. + push bx + call new_string + pop di + SETCDR(di,bx) + push di + + ; Read characters until the string is closed. + .add_loop: + call read_next_character + or al,al + jz error_unexpected_eoi + cmp al,'"' + je .done + + ; Handle escape codes. + cmp al,'\' + jne .append + call read_next_character + cmp al,'n' + jne .e1 + mov al,10 + .e1: + + ; Append the character. + .append: + call string_append_character + jmp .add_loop + + .done: + pop bx + ALL_POP(1) + ret + +; bp - all list (preserved) +; al - first character of symbol +read_symbol_object: + xor bx,bx + + ; Read characters into the buffer. + .loop: + cmp al,'[' + je .end_symbol + cmp al,']' + je .end_symbol + cmp al,';' + je .end_symbol + cmp al,'.' + je .end_symbol + cmp al,'"' + je .end_symbol + cmp al,' ' + je .end_symbol + cmp al,9 + je .end_symbol + cmp al,10 + je .end_symbol + or al,al + jz .end_symbol + + ; Store the characer, and read the next one. + cmp bx,MAX_SYMBOL_LENGTH + je error_symbol_too_long + mov [.buffer + bx],al + inc bx + call read_next_character + jmp .loop + .end_symbol: + mov byte [.buffer + bx],0 + mov [next_character],al + + ; Try to parse the symbol as an integer. + mov si,.buffer + call read_integer_object + jc .done + + ; Find the symbol. + mov si,.buffer + call find_symbol + + ; Create the object. + mov ax,TYPE_SYMBOL + mov dx,bx + call new_object + + .done: ret + .buffer: times (MAX_SYMBOL_LENGTH + 1) db 0 + +; bp - all list (preserved) +; si - buffer containing string +; returns object in bx, carry clear if not an integer +read_integer_object: + ; Is it negative? + mov dx,32767 + mov al,[si] + cmp al,'-' + jne .positive + mov dx,32768 + inc si + mov al,[si] + .positive: + + ; Is it an empty string? + or al,al + jz .not_integer + + ; Iterate through each digit + xor cx,cx + .digit_loop: + lodsb + or al,al + jz .done + cmp al,'0' + jb .not_integer + cmp al,'9' + ja .not_integer + + ; Check for overflow. + cmp cx,3276 + ja error_integer_too_large + + ; Multiply by 10. + push ax + push dx + mov ax,cx + mov bx,10 + mul bx + mov cx,ax + pop dx + pop ax + + ; Check for overflow. + mov bx,dx + xor ah,ah + sub bx,ax + add bx,'0' + cmp cx,bx + ja error_integer_too_large + + ; Add the digit. + add cx,ax + sub cx,'0' + jmp .digit_loop + + ; Negate the final result. + .done: + cmp dx,32768 + jne .negated + neg cx + .negated: + + ; Create the object. + mov dx,cx + mov ax,TYPE_INT + call new_object + stc + ret + + .not_integer: + clc + ret + +; bp - all list (preserved) +read_list_object: + sub sp,8 + mov di,sp + mov [ss:di+0],bp ; all + mov byte [ss:di+2],1 ; first + mov word [ss:di+4],0 ; result + mov word [ss:di+6],0 ; tail + + ; Loop until the list is closed. + .loop: + mov bp,[ss:di+0] + mov bx,[ss:di+4] + ALL_PUSH(bx) + call read_object + mov di,sp + + ; Check for end of list and dotted lists. + cmp bx,0xFFFF + jne .next_item + or al,al + jz error_unexpected_eoi + cmp al,']' + je .done + cmp al,'.' + je .dotted + jmp error_unknown + + ; Save the item. + .next_item: + ALL_PUSH(bx) + + ; Is this the first item in the list? + cmp byte [ss:di+2],1 + jne .not_first + + ; Create the pair and set it as the tail. + mov byte [ss:di+2],0 + mov ax,bx + xor dx,dx + call new_object + mov di,sp + mov [ss:di+4],bx + mov [ss:di+6],bx + jmp .loop + + ; Create the pair and add it to the tail. + .not_first: + mov ax,bx + xor dx,dx + call new_object + mov di,sp + mov si,[ss:di+6] + SETCDR(si, bx) + mov [ss:di+6],bx + jmp .loop + + ; Restore context and return. + .done: + mov bp,[ss:di+0] + mov bx,[ss:di+4] + add sp,8 + ret + + ; Dotted list. + .dotted: + cmp byte [ss:di+2],1 + je error_invalid_dot + + ; Read the final item. + call read_object + mov di,sp + cmp bx,0xFFFF + je error_invalid_dot + mov si,[ss:di+6] + SETCDR(si, bx) + + ; Read the closing brace. + call read_object + cmp bx,0xFFFF + jne error_invalid_dot + cmp al,']' + jne error_invalid_dot + jmp .done + +; returns next character in al +; overwrites si only +read_next_character: + mov al,[next_character] + mov byte [next_character],0 + or al,al + jnz .return + + cmp word [input_handle],0 + je .from_input_buffer + jmp .from_file + + .process: + cmp al,10 + jne .return + inc word [input_line] + .return: ret + + .from_input_buffer: + mov si,[input_offset] + mov al,[si + INPUT_BUFFER] + or al,al + jz .process + inc si + mov [input_offset],si + jmp .process + + .from_file: + pusha + mov si,[input_handle] + mov cx,1 + mov ax,ds + mov es,ax + mov di,.destination + call read_file + call has_error_file + jc error_read_file + or cx,cx + jnz .e1 + mov byte [.destination],0 + .e1: + popa + mov al,[.destination] + jmp .process + .destination: db 1 + +; bp - all list +; si - environment +; bx - object +; di - stack address to write updated enviornment, else 0 +; evaluated object returned in bx +; no registers preserved +evaluate_object: + CHECK_STACK_OVERFLOW + + ; Keep our environment. + ALL_PUSH(si) + + ; Check for Ctrl+C. + inc byte [check_break] + jnz .no_break + mov ah,1 + int 0x16 + jz .no_break + cmp ah,0x2E + jne .remove_key + mov ah,2 + int 0x16 + test al,(1 << 2) + jnz error_break + .remove_key: + mov [last_scancode],ah + xor ah,ah + int 0x16 + .no_break: + + ; Is the object a list? + CAR(ax, bx) + test ax,2 + jz .list + + ; Is the object a symbol? + cmp ax,TYPE_SYMBOL + je .symbol + + ; Otherwise, the object evalutes to itself. + cmp ax,TYPE_FREE + je error_free_accessible + ret + + ; Lookup the value of the symbol in the environment. + .symbol: + CDR(bx, bx) + call lookup_symbol + CDR(bx, bx) + ret + + ; Evaluate the function. + .list: + push bx + push bp + push si + push di + xor di,di + CAR(bx, bx) + call evaluate_object + pop di + pop si + pop bp + ALL_PUSH(bx) + + ; Is the function a builtin? + CAR(ax, bx) + cmp ax,TYPE_BUILTIN + je .builtin + + ; Is the function a lambda or macro? + cmp ax,TYPE_LAMBDA + je evaluate_lambda + cmp ax,TYPE_MACRO + je evaluate_macro + + ; Otherwise, the function object is not callable. + jmp error_not_callable + + ; Get the builtin ID and the start of the arguments list. + .builtin: + CDR(ax, bx) + pop bx + CDR(bx, bx) + + ; Call the builtin. + push di + mov di,ax + shl di,1 + mov ax,[di + builtin_functions] + or ax,ax + jz error_unimplemented_builtin + pop di + jmp ax + +%macro EVALUATE_LAMBDA_COMMON 1 + ; Extract information about the lambda. + CDR(bx, bx) + CDR(di, bx) ; di = new environment + CAR(bx, bx) + CDR(ax, bx) + CAR(dx, bx) ; dx = symbols + pop bx + push ax ; function body + CDR(bx, bx) ; bx = arguments + + ; For each argument... + .argument_loop: + or dx,dx + jz .environment_ready + ALL_PUSH(di) + mov cx,%1 + call next_argument + + ; Add it to the new environment. + push bx + push di + push dx + mov di,dx + CAR(di, di) + CDR(ax, di) + mov dx,cx + call new_object + ALL_PUSH(bx) + pop dx + mov di,dx + CDR(dx, di) + pop di + push dx + mov ax,bx + mov dx,di + call new_object + mov di,bx + pop dx + pop bx + + ALL_POP(3) + jmp .argument_loop + + ; Check we used all the arguments. + .environment_ready: + or bx,bx + jnz error_too_many_arguments +%endmacro + +evaluate_lambda: + EVALUATE_LAMBDA_COMMON NEXT_ARG_ANY | NEXT_ARG_KEEP + + ; Call the function body. + mov si,di + pop bx + jmp do_builtin_do + +evaluate_macro: + pop ax + push di ; old environment pointer + push si ; old environment + push bp ; all list + + ; Construct the new environment. + push ax + EVALUATE_LAMBDA_COMMON NEXT_ARG_ANY | NEXT_ARG_KEEP | NEXT_ARG_QUOTE + + ; Evaluate the arguments passed to the macro using the new environment. + mov si,di + ALL_PUSH(si) + pop bx + call do_builtin_list + + ; Evaluate the result using the old environment. + pop bp + pop si + pop di + ALL_PUSH(bx) + .loop: + or bx,bx + jz .done + mov cx,NEXT_ARG_QUOTE | NEXT_ARG_ANY + call next_argument + push bx + push di + push bp + push si + or di,di + jz .no_di + mov si,[ss:di] + .no_di: + mov bx,cx + call evaluate_object + pop si + pop bp + pop di + pop bx + jmp .loop + .done: + ret + +do_builtin_add: + xor dx,dx + .loop: + or bx,bx + jz .done + mov cx,TYPE_INT + call next_argument + mov di,cx + CDR(cx, di) + add dx,cx + jmp .loop + .done: + mov ax,TYPE_INT + jmp new_object + +do_builtin_subtract: + mov cx,TYPE_INT + call next_argument + mov di,cx + CDR(dx, di) + or bx,bx + jz .negate + .loop: + or bx,bx + jz .done + mov cx,TYPE_INT + call next_argument + mov di,cx + CDR(cx, di) + sub dx,cx + jmp .loop + .negate: + neg dx + .done: + mov ax,TYPE_INT + jmp new_object + +%macro MULDIV_START 0 + mov cx,TYPE_INT + call next_argument + mov di,cx + CDR(ax, di) + .loop: + mov cx,TYPE_INT + call next_argument + mov di,cx + CDR(cx, di) +%endmacro + +%macro MULDIV_END 0 + or bx,bx + jnz .loop + .done: + mov dx,ax + mov ax,TYPE_INT + jmp new_object +%endmacro + +do_builtin_multiply: + MULDIV_START + imul cx + MULDIV_END + +do_builtin_divide: + MULDIV_START + cwd + idiv cx + MULDIV_END + +do_builtin_modulo: + MULDIV_START + xor dx,dx + div cx + mov ax,dx + MULDIV_END + +do_builtin_muldiv: + mov cx,TYPE_INT + call next_argument + mov di,cx + CDR(ax, di) + mov cx,TYPE_INT + call next_argument + mov di,cx + CDR(cx, di) + imul cx + mov cx,TYPE_INT | NEXT_ARG_FINAL + call next_argument + mov di,cx + CDR(cx, di) + idiv cx + mov dx,ax + mov ax,TYPE_INT + jmp new_object + +do_builtin_quote: + mov cx,NEXT_ARG_FINAL | NEXT_ARG_QUOTE | NEXT_ARG_ANY | NEXT_ARG_BX + jmp next_argument + +do_builtin_car: + mov cx,NEXT_ARG_FINAL | NEXT_ARG_BX + call next_argument + CAR(bx, bx) + ret + +do_builtin_cdr: + mov cx,NEXT_ARG_FINAL | NEXT_ARG_BX + call next_argument + CDR(bx, bx) + ret + +do_builtin_setcar: + mov cx,NEXT_ARG_KEEP + call next_argument + mov di,cx + mov cx,NEXT_ARG_FINAL | NEXT_ARG_ANY + call next_argument + SETCAR(di, cx) + mov bx,di + ret + +do_builtin_setcdr: + mov cx,NEXT_ARG_KEEP + call next_argument + mov di,cx + mov cx,NEXT_ARG_FINAL | NEXT_ARG_ANY + call next_argument + SETCDR(di, cx) + mov bx,di + ret + +do_builtin_cons: + mov cx,NEXT_ARG_KEEP | NEXT_ARG_ANY + call next_argument + mov ax,cx + mov cx,NEXT_ARG_KEEP | NEXT_ARG_FINAL | NEXT_ARG_ANY + call next_argument + mov dx,cx + jmp new_object + +new_true: + mov ax,TYPE_INT + mov dx,1 + jmp new_object + +%macro COMPARE_COMMON 1 + mov cx,TYPE_INT + call next_argument + mov di,cx + CDR(ax, di) + mov cx,TYPE_INT | NEXT_ARG_FINAL | NEXT_ARG_BX + call next_argument + CDR(bx, bx) + cmp ax,bx + %1 new_true + xor bx,bx + ret +%endmacro + +do_builtin_lt: COMPARE_COMMON jl +do_builtin_lte: COMPARE_COMMON jle +do_builtin_gt: COMPARE_COMMON jg +do_builtin_gte: COMPARE_COMMON jge + +do_builtin_not: + mov cx,NEXT_ARG_ANY | NEXT_ARG_FINAL | NEXT_ARG_BX + call next_argument + or bx,bx + jz new_true + xor bx,bx + ret + +%macro PRINT_COMMON 0 + .loop: + or bx,bx + jz .done + mov cx,NEXT_ARG_ANY + call next_argument + pusha + mov bx,cx + mov cx,-100 + mov dx,1 + ALL_PUSH(bx) + call print_object + popa + jmp .loop + .done: +%endmacro + +do_builtin_print: + PRINT_COMMON + xor bx,bx + ret + +do_builtin_print_colored: + push word [output_color] + mov cx,TYPE_INT + call next_argument + mov di,cx + CDR(ax, di) + and ax,15 + mov [output_color],ax + mov cx,TYPE_INT + call next_argument + mov di,cx + CDR(ax, di) + and ax,15 + shl ax,4 + or [output_color],ax + PRINT_COMMON + xor bx,bx + pop word [output_color] + ret + +do_builtin_print_substr: + ; Get the starting index, the length to print, and the string itself. + mov cx,TYPE_INT + call next_argument + mov di,cx + CDR(ax, di) + push ax + mov cx,TYPE_INT + call next_argument + mov di,cx + CDR(ax, di) + or ax,ax + jz .out_of_bounds_seek + push ax + mov cx,TYPE_STRING | NEXT_ARG_FINAL | NEXT_ARG_BX + call next_argument + ALL_PUSH(bx) + CDR(bx, bx) + pop ax + pop cx + push ax + + ; Seek to the start of the substring. + .seek: + or bx,bx + jz .out_of_bounds_seek + cmp cx,6 + jb .in_section + STRING_NEXT(bx, bx) + sub cx,6 + jmp .seek + .in_section: + add bx,2 + .loop2: + or cx,cx + jz .seek_done + mov al,[gs:bx] + or al,al + jz .out_of_bounds_seek + inc bx + dec cx + jmp .loop2 + .seek_done: + + ; Print this section. + pop cx + .first_section: + test bx,7 + jz .first_done + mov al,[gs:bx] + or al,al + jz .done + call print_character + inc bx + loop .first_section + jmp .done + .first_done: + + ; Go to the first middle section. + sub bx,8 + STRING_NEXT(bx, bx) + + ; Print out full sections. + .middle_section: + or bx,bx + jz .done + cmp cx,6 + jl .last_section + mov si,print_string_list.buffer + mov al,[gs:bx+2] + mov [si+0],al + mov al,[gs:bx+3] + mov [si+1],al + mov al,[gs:bx+4] + mov [si+2],al + mov al,[gs:bx+5] + mov [si+3],al + mov al,[gs:bx+6] + mov [si+4],al + mov al,[gs:bx+7] + mov [si+5],al + call print_string + STRING_NEXT(bx, bx) + sub cx,6 + jmp .middle_section + or cx,cx + jz .done + + ; Print out the last section. + .last_section: + add bx,2 + .last_loop: + mov al,[gs:bx] + or al,al + jz .done + call print_character + inc bx + loop .last_loop + + .done: + xor bx,bx + ret + + .out_of_bounds_seek: + pop ax + xor bx,bx + ret + +do_builtin_poke: + mov cx,TYPE_INT + call next_argument + mov di,cx + CDR(ax, di) + mov cx,TYPE_INT + call next_argument + mov di,cx + CDR(di, di) + mov cx,TYPE_INT | NEXT_ARG_FINAL | NEXT_ARG_BX + call next_argument + CDR(cx, bx) + shl ax,12 + mov es,ax + mov [es:di],cl + xor bx,bx + ret + +do_builtin_peek: + mov cx,TYPE_INT + call next_argument + mov di,cx + CDR(ax, di) + mov cx,TYPE_INT + call next_argument + mov di,cx + CDR(di, di) + shl ax,12 + mov es,ax + xor dh,dh + mov dl,[es:di] + mov ax,TYPE_INT + jmp new_object + +do_builtin_atom: + mov cx,NEXT_ARG_ANY | NEXT_ARG_FINAL | NEXT_ARG_BX + call next_argument + CAR(ax, bx) + test ax,2 + jnz new_true + xor bx,bx + ret + +do_builtin_is: + mov cx,NEXT_ARG_ANY | NEXT_ARG_KEEP + call next_argument + mov di,cx + mov cx,NEXT_ARG_ANY | NEXT_ARG_FINAL | NEXT_ARG_BX + call next_argument + cmp di,bx + je new_true ; same IDs + CAR(ax, di) + CAR(cx, bx) + cmp ax,cx + jne .false ; different types + CDR(di, di) + CDR(bx, bx) + cmp ax,TYPE_INT + je .compare_cdr + cmp ax,TYPE_SYMBOL + je .compare_cdr + cmp ax,TYPE_STRING + je .compare_strings + .false: + xor bx,bx + ret + .compare_cdr: + cmp bx,di + je new_true ; same int/symbol + xor bx,bx + ret + .compare_strings: + call string_compare + jc new_true + xor bx,bx + ret + +do_builtin_and: + or bx,bx + jz new_true + mov cx,NEXT_ARG_ANY + call next_argument + or cx,cx + jnz do_builtin_and + xor bx,bx + ret + +do_builtin_or: + or bx,bx + jnz .test + xor bx,bx + ret + .test: + mov cx,NEXT_ARG_ANY + call next_argument + or cx,cx + jz do_builtin_or + jmp new_true + +do_builtin_if: + CDR(cx, bx) + or cx,cx + jz error_insufficient_arguments + .loop: + CDR(cx, bx) + or cx,cx + jz .true ; final else + mov cx,NEXT_ARG_ANY + call next_argument + or cx,cx + jnz .true + mov cx,NEXT_ARG_ANY | NEXT_ARG_QUOTE + call next_argument + jmp .loop ; false case + .true: + mov cx,NEXT_ARG_ANY | NEXT_ARG_BX | NEXT_ARG_TAIL + jmp next_argument ; true case + +%macro LAMBDA_COMMON 1 + mov ax,bx + mov cx,NEXT_ARG_NIL | NEXT_ARG_QUOTE + call next_argument + mov cx,NEXT_ARG_ANY | NEXT_ARG_QUOTE + call next_argument + mov dx,si + call new_object + ALL_PUSH(bx) + mov ax,%1 + mov dx,bx + jmp new_object +%endmacro + +do_builtin_lambda: + LAMBDA_COMMON TYPE_LAMBDA +do_builtin_macro: + LAMBDA_COMMON TYPE_MACRO + +do_builtin_list: + ; Check for an empty list. + or bx,bx + jnz .non_empty + ret + + ; Create the head of the list. + .non_empty: + mov cx,NEXT_ARG_ANY | NEXT_ARG_KEEP + call next_argument + mov ax,cx + xor dx,dx + push bx + call new_object + mov di,bx ; di = tail + pop bx + push di ; result on stack + ALL_POP(1) + ALL_PUSH(di) + + ; Loop through the rest of the items in the list. + .loop: + or bx,bx + jz .end + mov cx,NEXT_ARG_ANY | NEXT_ARG_KEEP + call next_argument + + ; Add it to the tail. + mov ax,cx + xor dx,dx + push bx + push di + call new_object + pop di + SETCDR(di, bx) + mov di,bx + pop bx + ALL_POP(1) + jmp .loop + + ; Return the head of the list. + .end: + pop bx + ret + +do_builtin_do: + mov cx,NEXT_ARG_QUOTE | NEXT_ARG_ANY + call next_argument + or bx,bx + jz .last_argument + push bx + push si + mov di,sp + push bp + mov bx,cx + ALL_PUSH(si) + call evaluate_object + pop bp + pop si + pop bx + jmp do_builtin_do + .last_argument: + xor di,di + mov bx,cx + ALL_POP(2) ; function and environment + jmp evaluate_object + +do_builtin_let: + or di,di + jz error_cannot_let + push di + mov cx,TYPE_SYMBOL | NEXT_ARG_QUOTE | NEXT_ARG_KEEP + call next_argument + mov di,cx + CDR(ax, di) + mov cx,NEXT_ARG_ANY | NEXT_ARG_FINAL | NEXT_ARG_KEEP + call next_argument + mov dx,cx + call new_object + ALL_PUSH(bx) + mov ax,bx + mov dx,si + call new_object + pop di + mov [ss:di],bx + xor bx,bx + ret + +do_builtin_set: + mov cx,TYPE_SYMBOL | NEXT_ARG_QUOTE | NEXT_ARG_KEEP + call next_argument + mov di,cx + CDR(di, di) + mov cx,NEXT_ARG_ANY | NEXT_ARG_FINAL + call next_argument + mov bx,di + call lookup_symbol + SETCDR(bx, cx) + mov bx,cx + ret + +do_builtin_while: + mov di,bx + .loop: + mov cx,NEXT_ARG_ANY + call next_argument + or cx,cx + jz .done + mov cx,NEXT_ARG_ANY | NEXT_ARG_FINAL + call next_argument + mov bx,di + jmp .loop + .done: + xor bx,bx + ret + +; cx - additional flags to pass to next_argument +; preserves bp, si +next_filename_argument: + or cx,TYPE_STRING + call next_argument + push bx + push si + mov bx,cx + CDR(bx, bx) + mov di,.name + mov cx,16 + call string_flatten + jc error_file_name_too_long + pop si + pop bx + ret + .name: times 16 db 0 + +do_builtin_src: + ; We need to be in a environment-updating context to use src. + or di,di + jz error_cannot_src + + push di + push si + push bp + + ; Get the name of the file to source. + mov cx,NEXT_ARG_FINAL + call next_filename_argument + + ; Open a handle to the file. + mov dx,FILE_READ + mov si,next_filename_argument.name + call open_file + cmp si,0xFFFF + je error_cannot_open_file + mov dx,si + + pop bp + pop si + + ; Save the previous input context. + mov al,[next_character] + push ax + mov ax,[input_line] + push ax + mov ax,[input_offset] + push ax + mov ax,[input_handle] + push ax + + ; Set the new input context. + mov byte [next_character],0 + mov word [input_line],1 + mov word [input_offset],0 + mov [input_handle],dx + + push bp + + .evaluate_loop: + + ; Reset the all list and push the environment. + pop bp + push bp + ALL_PUSH(si) + push si + + ; Read the object and put it on the all list. + call read_object + cmp bx,0xFFFF + je .last_object + ALL_PUSH(bx) + + ; Evaluate the object. + pop si + push si + mov di,sp + call evaluate_object + pop si + + jmp .evaluate_loop + + ; Check for stray tokens. + .last_object: + or al,al + jne error_unexpected_character + + ; Close file handle. + push si + mov si,[input_handle] + call close_file + pop si + + add sp,4 + + ; Restore the previous input context. + pop ax + mov [input_handle],ax + pop ax + mov [input_offset],ax + pop ax + mov [input_line],ax + pop ax + mov [next_character],al + + ; Save the environment. + pop di + mov [ss:di],si + + xor bx,bx + ret + +do_builtin_read: + ; Get the name of the file to type. + mov cx,NEXT_ARG_FINAL + call next_filename_argument + + ; Open a handle to the file. + mov dx,FILE_READ + mov si,next_filename_argument.name + call open_file + cmp si,0xFFFF + je error_cannot_open_file + + ; Read the file and print until done. + .loop: + mov ax,ds + mov es,ax + mov cx,TYPE_BUFFER_SIZE - 1 + mov di,TYPE_BUFFER + call read_file + call has_error_file + jc error_read_file + mov bx,cx + mov byte [TYPE_BUFFER + bx],0 + push si + mov si,TYPE_BUFFER + call print_string + pop si + or bx,bx + jnz .loop + call close_file + xor bx,bx + ret + +; ds:si - string +; result in cx +; null byte not counted +; preserves di, bx, dx +calculate_string_length: + xor cx,cx + .loop: + lodsb + or al,al + jz .done + inc cx + jmp .loop + .done: + ret + +write_string_to_file: + mov di,si + call calculate_string_length + mov si,[print_data] + mov ax,ds + mov es,ax + jmp write_file + +write_append_common: + push word [print_callback] + push word [print_data] + push si + push bx + + mov si,next_filename_argument.name + call open_file + cmp si,0xFFFF + je error_cannot_open_file + mov [print_data],si + mov word [print_callback],write_string_to_file + + pop bx + pop si + + mov cx,NEXT_ARG_FINAL | NEXT_ARG_ANY + call next_argument + + mov si,[print_data] + call close_file + + pop word [print_data] + pop word [print_callback] + + xor bx,bx + ret + +do_builtin_write: + xor cx,cx + call next_filename_argument + mov dx,FILE_WRITE + jmp write_append_common + +do_builtin_append: + xor cx,cx + call next_filename_argument + mov dx,FILE_APPEND + jmp write_append_common + +do_builtin_rename: + xor cx,cx + call next_filename_argument + + push si + push bx + mov si,next_filename_argument.name + mov dx,FILE_RENAME + call open_file + cmp si,0xFFFF + je error_cannot_open_file + mov di,si + pop bx + pop si + push di + + mov cx,NEXT_ARG_FINAL + call next_filename_argument + + mov si,next_filename_argument.name + mov dx,FILE_READ + call open_file + cmp si,0xFFFF + jne error_file_already_exists + + pop si + call close_file + xor bx,bx + ret + +do_builtin_delete: + mov cx,NEXT_ARG_FINAL + call next_filename_argument + mov dx,FILE_DELETE + mov si,next_filename_argument.name + call open_file + cmp si,0xFFFF + je error_cannot_open_file + call close_file + xor bx,bx + ret + +do_builtin_terminal: + push word [print_callback] + push word [print_data] + mov word [print_callback],terminal_print_string + mov cx,NEXT_ARG_FINAL | NEXT_ARG_ANY + call next_argument + pop word [print_data] + pop word [print_callback] + xor bx,bx + ret + +%macro LS_COMMON_START 0 + or bx,bx + jnz error_too_many_arguments + + ; Start reading the root directory from the beginning. + call start_reading_root_directory + + .loop: + + ; Read the next entry. + mov ax,ds + mov es,ax + mov si,ROOT_HANDLE + mov di,open_file.directory_entry + mov cx,0x20 + call read_file + + call has_error_file + jc error_read_file + or cx,cx + jz .done + cmp byte [open_file.directory_entry],0 + jz .loop +%endmacro + +%macro LS_COMMON_END 0 + jmp .loop + + .done: +%endmacro + +do_builtin_ls: + LS_COMMON_START + mov si,open_file.directory_entry + call print_string + call print_newline + LS_COMMON_END + xor bx,bx + ret + +do_builtin_dir: + xor ax,ax + mov [.total_size + 0],ax + mov [.total_size + 2],ax + LS_COMMON_START + mov dx,[open_file.directory_entry + 18] + or dx,dx + jnz .not_small + mov ax,[open_file.directory_entry + 16] + cmp ax,1000 + ja .not_small + call print_s16 + mov si,bytes_message + call print_string + jmp .common + .not_small: + mov cx,1000 + div cx + call print_s16 + mov si,kilobytes_message + call print_string + .common: + mov word [caret_column],8 + mov si,open_file.directory_entry + call print_string + call print_newline + mov ax,[open_file.directory_entry + 16] + mov cx,[open_file.directory_entry + 18] + add [.total_size + 0],ax + adc [.total_size + 2],cx + LS_COMMON_END + mov ax,[.total_size + 0] + shr ax,10 + mov bx,[.total_size + 2] + shl bx,6 + or ax,bx + mov si,total_usage_message + call print_string + call print_s16 + mov si,kilobytes_message + call print_string + mov si,out_of_message + call print_string + mov ax,[FS_HEADER_BUFFER + 4] + shr ax,1 + call print_s16 + mov si,kilobytes_message + call print_string + xor bx,bx + ret + .total_size: dd 0 + +do_builtin_strlen: + mov cx,TYPE_STRING | NEXT_ARG_FINAL | NEXT_ARG_BX + call next_argument + CDR(bx, bx) + xor dx,dx + .loop1: + or bx,bx + jz .done + mov cx,6 + STRING_NEXT(di, bx) + add bx,2 + .loop2: + mov al,[gs:bx] + or al,al + jz .done + inc bx + inc dx + loop .loop2 + mov bx,di + jmp .loop1 + .done: + mov ax,TYPE_INT + jmp new_object + +do_builtin_nth_char: + mov cx,TYPE_INT + call next_argument + mov di,cx + CDR(dx, di) + mov cx,TYPE_STRING | NEXT_ARG_FINAL | NEXT_ARG_BX + call next_argument + CDR(bx, bx) + mov cx,dx + .loop1: + or bx,bx + jz .out_of_bounds + cmp cx,6 + jb .in_section + STRING_NEXT(bx, bx) + sub cx,6 + jmp .loop1 + .in_section: + inc cx + add bx,2 + .loop2: + mov al,[gs:bx] + or al,al + jz .out_of_bounds + inc bx + loop .loop2 + .done: + xor ah,ah + mov dx,ax + mov ax,TYPE_INT + jmp new_object + .out_of_bounds: + xor dx,dx + mov ax,TYPE_INT + jmp new_object + +capture_common: + push si + push bx + mov ax,TYPE_STRING + xor dx,dx ; must be valid since new_string might gc + call new_object + ALL_PUSH(bx) + push bx + call new_string + mov dx,bx + pop bx + SETCDR(bx, dx) + mov [print_data],dx + mov dx,bx + pop bx + pop si + push dx + mov cx,NEXT_ARG_FINAL | NEXT_ARG_ANY + call next_argument + pop bx + pop word [print_data] + pop word [print_callback] + ret + +%macro CAPTURE_START 1 + push word [print_callback] + push word [print_data] + mov word [print_callback],%1 + jmp capture_common +%endmacro + +capture_string: + lodsb + or al,al + jz .done + mov bx,[print_data] + push si + call string_append_character + pop si + mov [print_data],bx + jmp capture_string + .done: ret + +do_builtin_capture: + CAPTURE_START capture_string + +capture_string_lower: + lodsb + or al,al + jz .done + mov bx,[print_data] + cmp al,'A' + jb .no_convert + cmp al,'Z' + ja .no_convert + add al,'a'-'A' + .no_convert: + push si + call string_append_character + pop si + mov [print_data],bx + jmp capture_string_lower + .done: ret + +do_builtin_capture_lower: + CAPTURE_START capture_string_lower + +capture_string_upper: + lodsb + or al,al + jz .done + mov bx,[print_data] + cmp al,'a' + jb .no_convert + cmp al,'z' + ja .no_convert + sub al,'a'-'A' + .no_convert: + push si + call string_append_character + pop si + mov [print_data],bx + jmp capture_string_upper + .done: ret + +do_builtin_capture_upper: + CAPTURE_START capture_string_upper + +set_graphics_mode: + mov al,[graphics_mode] + or al,al + jnz .done + mov byte [graphics_mode],1 + mov ax,0xA000 + mov es,ax + xor di,di + xor al,al + mov cx,320 * 200 + rep stosb + mov ax,0x13 + int 0x10 + .done: ret + +set_text_mode: + mov al,[graphics_mode] + or al,al + jz .done + mov byte [graphics_mode],0 + call clear_screen + mov ax,0x03 + int 0x10 + mov word [caret_column],1 + mov word [caret_row],0 + .done: ret + +do_builtin_set_graphics: + mov cx,NEXT_ARG_FINAL | NEXT_ARG_ANY + call next_argument + or cx,cx + jz .text + call set_graphics_mode + xor bx,bx + ret + .text: + call set_text_mode + xor bx,bx + ret + +do_builtin_wait_key: + or bx,bx + jnz error_too_many_arguments + xor ax,ax + int 0x16 + xor bx,bx + ret + +do_builtin_env_reset: + or di,di + jz error_cannot_env + or bx,bx + jnz error_too_many_arguments + mov ax,[obj_builtins] + mov [ss:di],ax + mov byte [run_startup_command],0 + xor bx,bx + ret + +do_builtin_env_list: + push word [output_color] + or bx,bx + jnz error_too_many_arguments + .loop: + or si,si + jz .done + CAR(bx, si) + CDR(di, bx) + CAR(ax, di) + CAR(bx, bx) + CDR(bx, bx) + cmp ax,TYPE_MACRO + je .alt + cmp ax,TYPE_BUILTIN + je .alt2 + cmp ax,TYPE_LAMBDA + je .alt3 + mov byte [output_color],(SCREEN_COLOR >> 8) + .print: + push si + call print_string_list + mov byte [output_color],(SCREEN_COLOR >> 8) + mov si,space_message + call print_string + pop si + CDR(si, si) + jmp .loop + .done: + call print_newline + mov si,memory_usage_message + call print_string + call get_memory_usage + shr ax,8 + inc ax + call print_s16 + mov si,kilobytes_message + call print_string + mov si,out_of_message + call print_string + mov ax,128 + call print_s16 + mov si,kilobytes_message + call print_string + xor bx,bx + pop word [output_color] + ret + .highlight: + mov byte [output_color],(HIGHLIGHT_COLOR >> 8) + jmp .print + .alt: + mov byte [output_color],(ALT_COLOR >> 8) + jmp .print + .alt2: + mov byte [output_color],(ALT2_COLOR >> 8) + jmp .print + .alt3: + mov byte [output_color],(ALT3_COLOR >> 8) + jmp .print + +do_builtin_env_export: + ; Open the file to export to. + mov cx,NEXT_ARG_FINAL + call next_filename_argument + mov dx,FILE_WRITE + mov si,next_filename_argument.name + call open_file + cmp si,0xFFFF + je error_cannot_open_file + + ; Garbage collect now to reduce export size. + push si + call garbage_collect + pop si + + ; Write out a signature. + mov word [.buffer + 0],'en' + mov word [.buffer + 2],('v' + 0x1000) + mov di,.buffer + mov ax,ds + mov es,ax + mov cx,4 + call write_file + + ; For each object... + xor bx,bx + .object_loop: + add bx,OBJ_SIZE + or bx,bx + jz .object_done + CAR(ax, bx) + cmp ax,TYPE_FREE + je .object_loop + + ; Write out the ID and contents. + mov [.buffer + 0],bx + mov [.buffer + 2],ax + CDR(ax, bx) + mov [.buffer + 4],ax + mov di,.buffer + mov ax,ds + mov es,ax + mov cx,6 + push bx + call write_file + pop bx + jmp .object_loop + .object_done: + + ; Write separator. + mov word [.buffer],0 + mov di,.buffer + mov ax,ds + mov es,ax + mov cx,6 + call write_file + + ; For each string... + xor bx,bx + .string_loop: + add bx,STRING_SIZE + or bx,bx + jz .string_done + STRING_NEXT(ax, bx) + test ax,2 + jnz .string_loop + + ; Write out the ID and contents. + mov [.buffer + 0],bx + mov [.buffer + 2],ax + mov ax,[gs:bx + 2] + mov [.buffer + 4],ax + mov ax,[gs:bx + 4] + mov [.buffer + 6],ax + mov ax,[gs:bx + 6] + mov [.buffer + 8],ax + mov di,.buffer + mov ax,ds + mov es,ax + mov cx,10 + push bx + call write_file + pop bx + jmp .string_loop + .string_done: + + ; Write separator. + mov word [.buffer],0 + mov di,.buffer + mov ax,ds + mov es,ax + mov cx,10 + call write_file + + ; Save the environment ID and symbol table. + mov ax,[repl.environment] + mov [.buffer + 0],ax + mov ax,[obj_symbol_table] + mov [.buffer + 2],ax + mov di,.buffer + mov ax,ds + mov es,ax + mov cx,4 + call write_file + + call close_file + xor bx,bx + ret + + .buffer: times 10 db 0 + +do_builtin_env_import: + or di,di + jz error_cannot_env + mov [.environment_dest],di + + ; Open the file to import from. + mov cx,NEXT_ARG_FINAL + call next_filename_argument + mov dx,FILE_READ + mov si,next_filename_argument.name + call open_file + cmp si,0xFFFF + je error_cannot_open_file + + ; Garbage collect now, since we can't during the import. + push si + call garbage_collect + mov byte [gc_ready],0 + pop si + + ; Clear the re-link segment. + mov ax,0x4000 + mov es,ax + mov cx,32768 + xor ax,ax + xor di,di + rep stosw + + ; Check the file signature. + mov cx,4 + mov ax,ds + mov es,ax + mov di,.buffer + call read_file + cmp cx,4 + jne error_read_file + cmp word [.buffer + 0],'en' + jne error_bad_signature + cmp word [.buffer + 2],('v' + 0x1000) + jne error_bad_signature + + ; Load the objects. + .load_object_loop: + mov cx,6 + mov ax,ds + mov es,ax + mov di,.buffer + call read_file + cmp cx,6 + jne error_read_file + cmp word [.buffer],0 + jz .load_object_done + mov ax,[.buffer + 2] + mov dx,[.buffer + 4] + call new_object + mov ax,0x4000 + mov es,ax + mov di,[.buffer + 0] + shr di,1 + mov [es:di],bx + jmp .load_object_loop + .load_object_done: + + ; Load the strings. + .load_string_loop: + mov cx,10 + mov ax,ds + mov es,ax + mov di,.buffer + call read_file + cmp cx,10 + jne error_read_file + cmp word [.buffer],0 + jz .load_string_done + call new_string + mov ax,[.buffer + 2] + mov [gs:bx + 0],ax + mov ax,[.buffer + 4] + mov [gs:bx + 2],ax + mov ax,[.buffer + 6] + mov [gs:bx + 4],ax + mov ax,[.buffer + 8] + mov [gs:bx + 6],ax + mov ax,0x4000 + mov es,ax + mov di,[.buffer + 0] + shr di,2 + mov [es:di + 0x8000],bx + jmp .load_string_loop + .load_string_done: + + ; Load the environment ID and symbol table. + mov cx,4 + mov ax,ds + mov es,ax + mov di,.buffer + call read_file + cmp cx,4 + jne error_read_file + mov ax,[.buffer + 0] + mov [.environment],ax + mov ax,[.buffer + 2] + mov [.symbol_table],ax + + ; Close the file. + call close_file + + ; Use the re-link table segment. + mov ax,0x4000 + mov es,ax + + ; Re-link objects. + call .relink_objects + + ; Re-link strings. + mov bx,0x8000 + .link_string_loop: + cmp bx,0xC000 + je .link_string_done + mov di,[es:bx] + or di,di + jz .link_string_next + STRING_NEXT(si, di) + or si,si + jz .link_string_next + shr si,2 + mov ax,[es:si + 0x8000] + mov [gs:di],ax + .link_string_next: + add bx,2 + jmp .link_string_loop + .link_string_done: + + ; Save the new environment ID and symbol table before we identity map the link table. + mov si,[.symbol_table] + shr si,1 + mov si,[es:si] + mov [.symbol_table],si + mov si,[.environment] + shr si,1 + mov si,[es:si] + mov [.environment],si + + ; Identity map all objects. + mov ax,0x4000 + mov es,ax + mov cx,65536 / OBJ_SIZE + xor ax,ax + xor di,di + .identity_loop: + mov [es:di],ax + add di,2 + add ax,4 + loop .identity_loop + + ; Identity map all strings. + mov cx,65536 / STRING_SIZE + xor ax,ax + mov di,0x8000 + .identity_loop2: + mov [es:di],ax + add di,2 + add ax,8 + loop .identity_loop2 + + ; Intern symbols. + mov si,[.symbol_table] + .symbol_loop: + or si,si + jz .symbol_done + CAR(bx, si) + push si + mov di,.symbol + mov cx,(MAX_SYMBOL_LENGTH + 1) + CDR(bx, bx) + call string_flatten + mov si,.symbol + call find_symbol + pop si + CAR(di, si) + shr di,1 + mov ax,0x4000 + mov es,ax + mov [es:di],bx + CDR(si, si) + jmp .symbol_loop + .symbol_done: + + ; Re-link objects again to use interned symbols. + call .relink_objects + + ; Append the environment. + mov si,[.environment] + .environment_loop: + CDR(ax, si) + or ax,ax + jz .environment_found + mov si,ax + jmp .environment_loop + .environment_found: + mov bx,[.environment_dest] + mov ax,[ss:bx] + SETCDR(si, ax) + mov si,[.environment] + mov [ss:bx],si + + ; We're done! + mov byte [gc_ready],1 + xor bx,bx + ret + + .buffer: times 10 db 0 + .environment: dw 0 + .environment_dest: dw 0 + .symbol: times (MAX_SYMBOL_LENGTH + 1) db 0 + .symbol_table: dw 0 + + .relink_objects: + xor bx,bx + mov ax,0x4000 + mov es,ax + .link_object_loop: + cmp bx,0x8000 + je .link_object_done + mov di,[es:bx] + or di,di + jz .link_object_next + CAR(si, di) + cmp si,TYPE_LAMBDA + je .link_cdr + cmp si,TYPE_MACRO + je .link_cdr + cmp si,TYPE_SYMBOL + je .link_cdr + test si,2 + jz .link_both + cmp si,TYPE_STRING + jne .link_object_next + CDR(si, di) + shr si,2 + mov ax,[es:si + 0x8000] + SETCDR(di, ax) + .link_object_next: + add bx,2 + jmp .link_object_loop + .link_both: + shr si,1 + mov ax,[es:si] + SETCAR(di, ax) + .link_cdr: + CDR(si, di) + shr si,1 + mov ax,[es:si] + SETCDR(di, ax) + add bx,2 + jmp .link_object_loop + .link_object_done: + ret + +do_builtin_inspect: + mov cx,NEXT_ARG_FINAL | NEXT_ARG_ANY | NEXT_ARG_BX + call next_argument + CAR(ax, bx) + cmp ax,TYPE_LAMBDA + je .inspect + cmp ax,TYPE_MACRO + je .inspect + .print: + mov cx,-100 + xor dx,dx + ALL_PUSH(bx) + call print_object + xor bx,bx + ret + .inspect: + CDR(bx, bx) + CAR(bx, bx) + jmp .print + +do_builtin_pause: + or bx,bx + jnz error_too_many_arguments + .loop: + xor ah,ah + int 0x1A + cmp dx,[.previous_time] + je .loop + mov [.previous_time],dx + add [do_builtin_random.seed],dx + add [do_builtin_random.seed],cx + xor bx,bx + ret + .previous_time: dw 0 + +do_builtin_last_scancode: + or bx,bx + jnz error_too_many_arguments + + mov ah,1 + int 0x16 + jz .none + mov [last_scancode],ah + xor ah,ah + int 0x16 + + .none: + mov ax,TYPE_INT + mov dx,[last_scancode] + jmp new_object + +do_builtin_random: + or bx,bx + jnz error_too_many_arguments + mov ax,[.seed] + add ax,12345 + mov cx,9781 + mul cx + mov dx,ax + mov ax,TYPE_INT + jmp new_object + .seed: dw 0 + +do_builtin_outb: + mov cx,TYPE_INT + call next_argument + mov di,cx + CDR(di, di) + mov cx,TYPE_INT | NEXT_ARG_FINAL | NEXT_ARG_BX + call next_argument + CDR(ax, bx) + mov dx,di + out dx,al + xor bx,bx + ret + +; bp - all list (preserved, unless _KEEP set) +; si - environment (preserved) +; bx - argument list pointer (updated) +; cx - desired argument type and flags +; argument stored in cx +; additionally preserves ax, dx and di +next_argument: + ; Check there is another argument. + or bx,bx + jz error_insufficient_arguments + + push dx + push di + mov dx,cx + + ; Get the next argument and go to the next element in the list. + CAR(cx, bx) + CDR(bx, bx) + + ; Check this is the last argument, if requested. + test dx,NEXT_ARG_FINAL + jz .done_final_check + or bx,bx + jnz error_too_many_arguments + .done_final_check: + + ; Evaluate the argument with tail call recursion, if requested. + test dx,NEXT_ARG_TAIL + jz .done_tail + add sp,4 ; pop dx, di + mov bx,cx + xor di,di + ALL_POP(2) ; function and environment + jmp evaluate_object + .done_tail: + + ; Evaluate the argument, if requested. + test dx,NEXT_ARG_QUOTE + jnz .done_evaluate + push ax + push bx + push dx + push si + push bp + mov bx,cx + xor di,di + call evaluate_object + mov cx,bx + pop bp + pop si + pop dx + pop bx + pop ax + .done_evaluate: + + ; Add the result to the all list, if requested. + test dx,NEXT_ARG_KEEP + jz .done_keep + ALL_PUSH(cx) + .done_keep: + + ; Check the type is correct, if requested. + test dx,NEXT_ARG_NIL + jz .no_nil_flag + or cx,cx + jz .done_type_check + .no_nil_flag: + test dx,NEXT_ARG_ANY + jnz .done_type_check + mov di,cx + CAR(di, di) + or dl,dl + jnz .type_non_pair + and di,2 + .type_non_pair: + push dx + xor dh,dh + cmp dx,di + jne error_wrong_type + pop dx + .done_type_check: + + ; Move the result to bx, if requested. + test dx,NEXT_ARG_BX + jz .done_bx + mov bx,cx + .done_bx: + + pop di + pop dx + + ret + +; bx - environment +tidy_environment: + ; Mark all string objects in use, and mark all duplicates. + push bx + .mark_loop: + or bx,bx + jz .mark_done + CAR(di, bx) + CAR(di, di) + CAR(si, di) + test si,1 + jnz .already_marked + or si,1 + SETCAR(di, si) + jmp .mark_next + .already_marked: + xor ax,ax + SETCAR(bx, ax) + .mark_next: + CDR(bx, bx) + jmp .mark_loop + .mark_done: + pop bx + + ; Unlink duplicates. + push bx + .unlink_loop: + or bx,bx + jz .unlink_done + CAR(ax, bx) + or ax,ax + jnz .unlink_next + CDR(si, bx) + SETCDR(di, si) + mov bx,di + .unlink_next: + mov di,bx + CDR(bx, bx) + jmp .unlink_loop + .unlink_done: + pop bx + + ; Finally, remove the mark from the string objects. + .unmark_loop: + or bx,bx + jz .unmark_done + CAR(di, bx) + CAR(di, di) + CAR(si, di) + and si,~1 + SETCAR(di, si) + CDR(bx, bx) + jmp .unmark_loop + .unmark_done: + + ret + +; si - environment +; bx - canonical string object for symbol +; returns object in bx +; preserves ax, cx, dx +lookup_symbol: + ; Are we at the end of the environment list? + or si,si + jz error_symbol_not_found + + ; Does the string object match? + CAR(di, si) + CAR(di, di) + cmp di,bx + je .match + + ; Go to the next value in the environment. + CDR(si, si) + jmp lookup_symbol + + ; Return the value pair. + .match: + CAR(bx, si) + ret + +; bp - all list (preserved) +; si - string to search for +; returns object in bx +find_symbol: + ; Look through the symbol table for a match. + mov di,[obj_symbol_table] + .table_loop: + or di,di + jz .not_found + CAR(bx, di) + CDR(bx, bx) + push si + call string_compare_with_literal + pop si + jc .match + CDR(di, di) + jmp .table_loop + .match: + CAR(bx, di) + ret + + ; Create a new string object. + .not_found: + push si + mov ax,TYPE_STRING + xor dx,dx ; new_string could gc, so this should be valid + call new_object + ALL_PUSH(bx) + push bx + call new_string + pop di + SETCDR(di,bx) + push di + + ; Add the string object to the symbol table. + push bx + mov ax,di + mov dx,[obj_symbol_table] + call new_object + mov [obj_symbol_table],bx + ALL_POP(1) + + ; Append the characters to the string. + pop bx + pop di + pop si + push di + .append_loop: + lodsb + or al,al + jz .string_complete + push si + call string_append_character + pop si + jmp .append_loop + .string_complete: + + pop bx + ret + +; bp - all list (preserved) +; bx - string (modified if tail section changes) +; al - character +string_append_character: + push bx + + ; Look for a free place in the current section. + mov cx,STRING_DATA + add bx,2 + .loop: + cmp byte [gs:bx],0 + je .store + inc bx + loop .loop + sub bx,8 + + ; Allocate a new section. + push ax + call new_string + pop ax + pop si + mov [gs:si],bx + push bx + add bx,2 + + ; Store the character. + .store: + mov [gs:bx],al + pop bx + ret + +; bx - string 1 +; di - string 2 +; carry set if equal +string_compare: + mov cx,STRING_DATA + STRING_NEXT(dx, bx) + STRING_NEXT(si, di) + add bx,2 + add di,2 + .loop: + mov al,[gs:di] + cmp al,[gs:bx] + jne .not_equal + or al,al + je .equal + inc bx + inc di + loop .loop + mov bx,dx + mov di,si + jmp string_compare + .not_equal: + clc + ret + .equal: + stc + ret + +; bx - string +; si - literal +; carry set if equal +; preserves di +string_compare_with_literal: + mov cx,STRING_DATA + STRING_NEXT(dx, bx) + add bx,2 + .loop: + lodsb + cmp al,[gs:bx] + jne string_compare.not_equal + or al,al + je string_compare.equal + inc bx + loop .loop + mov bx,dx + jmp string_compare_with_literal + +; bx - string +; di - destination buffer +; cx - size of the destination buffer (including space to put null byte) +; carry set if destination buffer was too small +; preserves bp +string_flatten: + mov si,cx + .next_section: + mov cx,STRING_DATA + STRING_NEXT(dx, bx) + add bx,2 + .loop: + mov al,[gs:bx] + inc bx + or si,si + jz .full + mov [di],al + inc di + dec si + or al,al + jz .done + loop .loop + mov bx,dx + jmp .next_section + .done: + clc + ret + .full: + stc + ret + +; bp - all list (preserved) +; returns string in bx +new_string: +%ifdef ALWAYS_GC + call garbage_collect +%endif + + ; If there are no more free string, call the garbage collector. + cmp word [first_free_string],0 + jne .got_memory + call garbage_collect + cmp word [first_free_string],0 + je error_out_of_memory + .got_memory: + + ; Remove the first free string from the list. + mov bx,[first_free_string] + STRING_NEXT(ax, bx) + and ax,0xFFFC + mov [first_free_string],ax + + ; Clear the contents of the string. + xor ax,ax + mov word [gs:bx+0],ax + mov word [gs:bx+2],ax + mov word [gs:bx+4],ax + mov word [gs:bx+6],ax + + ret + +; bp - all list (preserved) +; ax - low word (preserved) +; dx - high word (preserved) +; returns object in bx +; additionally preserves si +new_object: + push ax + push dx + push si + +%ifdef ALWAYS_GC + call garbage_collect +%endif + + ; If there are no more free objects, call the garbage collector. + cmp word [first_free_object],0 + jne .got_memory + call garbage_collect + cmp word [first_free_object],0 + je error_out_of_memory + .got_memory: + + ; Remove the first free object from the list. + mov bx,[first_free_object] + CDR(ax, bx) + mov [first_free_object],ax + + ; Set the contents of the object. + pop si + pop dx + pop ax + SETCAR(bx, ax) + SETCDR(bx, dx) + + ret + +; bp - all list (preserved) +garbage_collect: + ; If we system has not yet been initialized, then we can't garbage collect. + cmp byte [gc_ready],0 + je .done + + ; Mark the all list and the symbol table. + mov bx,[obj_symbol_table] + call mark_object + mov di,bp + .mark_loop: + cmp di,ALL_LIST_TOP + je .mark_complete + mov bx,[ss:di] + call mark_object + add di,2 + jmp .mark_loop + .mark_complete: + + ; Iterate over all strings. + mov cx,(65536 / STRING_SIZE - 1) + mov bx,STRING_SIZE + .string_loop: + + ; Store and clear the mark. + STRING_NEXT(ax, bx) + and byte [gs:bx],0xFE + + ; If the mark is set, or the string was already free, don't free the string. + test ax,3 + jnz .next_string + + ; Free the string. + mov ax,[first_free_string] + or ax,2 + mov word [gs:bx],ax + mov [first_free_string],bx + + ; Go to the next string. + .next_string: + add bx,STRING_SIZE + loop .string_loop + + ; Iterate over all objects. + mov cx,(65536 / OBJ_SIZE - 1) + mov bx,OBJ_SIZE + .object_loop: + + ; Store and clear the mark. + CAR(ax, bx) + and byte [fs:bx],0xFE + + ; If the mark is set, or the object was already free, don't free the object. + test ax,1 + jnz .next_object + cmp ax,TYPE_FREE + je .next_object + + ; Free the object. + mov ax,[first_free_object] + SETCDR(bx, ax) + mov ax,TYPE_FREE + SETCAR(bx, ax) + mov [first_free_object],bx + + ; Go to the next object. + .next_object: + add bx,OBJ_SIZE + loop .object_loop + + .done: + ret + +get_memory_usage: + call garbage_collect + xor ax,ax + + ; Count used objects. + xor bx,bx + mov cx,(65536 / OBJ_SIZE) + .object_loop: + CAR(dx, bx) + cmp dx,TYPE_FREE + je .object_free + inc ax + .object_free: + add bx,OBJ_SIZE + loop .object_loop + + ; Count used strings. + xor bx,bx + mov cx,(65536 / STRING_SIZE) + .string_loop: + STRING_NEXT(dx, bx) + test dx,2 + jnz .string_free + add ax,2 + .string_free: + add bx,STRING_SIZE + loop .string_loop + + ret + +; bx - object to recursively GC mark +; preserves bp +mark_object: + CHECK_STACK_OVERFLOW + + ; Don't mark the nil object. + or bx,bx + jz .done + + ; Has the object already been marked? + CAR(ax, bx) + test ax,1 + jnz .done + + ; Mark the object. + or byte [fs:bx],1 + + ; Is the object a pair? + test ax,2 + jz .mark_both + + ; Is the object a lambda or macro? + cmp ax,TYPE_LAMBDA + je .mark_cdr + cmp ax,TYPE_MACRO + je .mark_cdr + + ; Is the object a string? + cmp ax,TYPE_STRING + je .string + + cmp ax,TYPE_FREE + je error_free_accessible + + .done: + ret + + .mark_both: + push bx + mov bx,ax + call mark_object + pop bx + .mark_cdr: + CDR(bx, bx) + jmp mark_object + + .string: + CDR(bx, bx) + jmp mark_string + +; bx - string to GC mark +; preserves bp +mark_string: + ; Don't mark the nil string. + or bx,bx + jz .done + + ; Has the section already been marked? + STRING_NEXT(ax, bx) + test ax,2 + jnz .done + + ; Mark the section. + or byte [gs:bx],1 + + ; Go to the next section. + mov bx,ax + jmp mark_string + + .done: + ret + +; preserves all registers +reset_output: + pusha + mov byte [output_color],(SCREEN_COLOR >> 8) + mov word [print_callback],terminal_print_string + call set_text_mode + popa + ret + +; ax - message +error_runtime: + call reset_output + mov si,.message + call print_string + mov si,ax + call print_string + jmp [recover] + .message: db 'Runtime error: ',0 + +error_out_of_memory: + mov ax,.message + jmp error_runtime + .message: db 'out of memory',10,0 + +error_stack_overflow: + mov ax,.message + jmp error_runtime + .message: db 'stack overflow',10,0 + +; ax - message +error_read: + call reset_output + mov si,.message + call print_string + mov si,ax + call print_string + mov si,.line + call print_string + mov ax,[input_line] + call print_s16 + call print_newline + jmp [recover] + .message: db 'Read error: ',0 + .line: db 'at line ',0 + +error_unexpected_eoi: + mov ax,.message + jmp error_read + .message: db 'unexpected end of input',10,0 + +error_symbol_too_long: + mov ax,.message + jmp error_read + .message: db 'symbol too long (max is 24 characters)',10,0 + +error_integer_too_large: + mov ax,.message + jmp error_read + .message: db 'integer too large (must be between -32768 and 32767)',10,0 + +error_invalid_dot: + mov ax,.message + jmp error_read + .message: db 'invalid dotted list (dot must be after penultimate item)',10,0 + +error_unexpected_character: + mov ax,.message + jmp error_read + .message: db 'unexpected character',10,0 + +; ax - message +; bx - object +error_evaluate: + call reset_output + mov si,.message + call print_string + mov si,ax + call print_string + mov cx,-5 + or bx,bx + jz .no_object + call print_object + .no_object: + call print_newline + jmp [recover] + .message: db 'Evaluate error: ',0 + +error_symbol_not_found: + mov ax,.message + jmp error_evaluate + .message: db 'symbol not found - ',0 + +error_not_callable: + mov ax,.message + jmp error_evaluate + .message: db 'object not callable',10,0 + +error_insufficient_arguments: + xor bx,bx + mov ax,.message + jmp error_evaluate + .message: db 'insufficient arguments',10,0 + +error_too_many_arguments: + mov ax,.message + jmp error_evaluate + .message: db 'too many arguments',10,0 + +error_wrong_type: + mov bx,cx + mov ax,.message + jmp error_evaluate + .message: db 'incorrect argument type',10,0 + +error_cannot_let: + mov ax,.message + jmp error_evaluate + .message: db 'cannot use let in this context',10,0 + +error_cannot_src: + mov ax,.message + jmp error_evaluate + .message: db 'cannot use src in this context',10,0 + +error_cannot_env: + mov ax,.message + jmp error_evaluate + .message: db 'cannot modify environment in this context',10,0 + +error_file_name_too_long: + xor bx,bx + mov ax,.message + jmp error_evaluate + .message: db 'the file name is too long (max 15 characters)',10,0 + +error_cannot_open_file: + xor bx,bx + mov ax,.message + jmp error_evaluate + .message: db 'the file could not be found, or is already in use',10,0 + +error_file_already_exists: + xor bx,bx + mov ax,.message + jmp error_evaluate + .message: db 'the file already exists',10,0 + +error_read_file: + xor bx,bx + mov ax,.message + jmp error_evaluate + .message: db 'the file could not be read',10,0 + +error_divide_error: + xor bx,bx + mov ax,.message + jmp error_evaluate + .message: db 'divide error (division by zero, or muldiv result too large)',10,0 + +error_break: + xor bx,bx + mov ax,.message + jmp error_evaluate + .message: db 'Ctrl+C pressed',10,0 + +error_bad_signature: + xor bx,bx + mov ax,.message + jmp error_evaluate + .message: db 'file does not contain environment',10,0 + +; ax - message +error_internal: + call reset_output + mov si,.message + call print_string + mov si,ax + call print_string + hlt + jmp $ + .message: db 'Internal error: ',0 + +error_free_accessible: + mov ax,.message + jmp error_internal + .message: db 'an accessible object was freed',10,0 + +error_unknown: + mov ax,.message + jmp error_internal + .message: db 'general failure',10,0 + +error_unimplemented_builtin: + mov ax,.message + jmp error_internal + .message: db 'unimplemented builtin',10,0 + +error_io_fatal: + mov ax,.message + jmp error_internal + .message: db 'could not access boot disk',10,0 + +install_exception_handlers: + xor ax,ax + mov es,ax + mov word [es: 0],error_divide_error + mov word [es: 2],0x1000 + mov word [es: 4],error_unknown + mov word [es: 6],0x1000 + mov word [es: 8],error_unknown + mov word [es:10],0x1000 + mov word [es:12],error_unknown + mov word [es:14],0x1000 + mov word [es:16],error_unknown + mov word [es:18],0x1000 + mov word [es:20],error_unknown + mov word [es:22],0x1000 + mov word [es:24],error_unknown + mov word [es:26],0x1000 + mov word [es:28],error_unknown + mov word [es:30],0x1000 + ret + +; bx - object +; cx - depth limit +; dx - 0 to quote strings +; bp - all list (preserved) +print_object: + CHECK_STACK_OVERFLOW + + CAR(ax, bx) + + cmp ax,TYPE_BUILTIN + je .builtin + cmp ax,TYPE_SYMBOL + je .symbol + cmp ax,TYPE_STRING + je .string + cmp ax,TYPE_NIL + je .nil + cmp ax,TYPE_INT + je .integer + cmp ax,TYPE_LAMBDA + je .lambda + cmp ax,TYPE_MACRO + je .macro + + and ax,2 + cmp ax,0 + je .pair + + mov si,unknown_type_message + jmp print_string + + .builtin: + mov si,builtin_message + call print_string + CDR(ax, bx) + call print_s16 + mov si,close_sign_message + call print_string + ret + + .symbol: + CDR(bx, bx) + CDR(bx, bx) + jmp print_string_list + + .string: + or dl,dl + jnz .unquoted_string + mov si,string_quote_message + call print_string + CDR(bx, bx) + call print_string_list + mov si,string_quote_message + jmp print_string + .unquoted_string: + CDR(bx, bx) + jmp print_string_list + + .nil: + mov si,nil_message + jmp print_string + + .lambda: + mov si,lambda_message + call print_string + CDR(ax, bx) + call print_word + mov si,close_sign_message + call print_string + ret + + .macro: + mov si,macro_message + call print_string + CDR(ax, bx) + call print_word + mov si,close_sign_message + call print_string + ret + + .integer: + CDR(ax, bx) + jmp print_s16 + + .pair: + mov si,list_start_message + call print_string + cmp cx,-1 + je .depth_limit_reached + inc cx + push cx + push bx + CAR(bx, bx) + xor dx,dx + call print_object + pop bx + pop cx + CDR(bx, bx) + + .list_loop: + CAR(ax, bx); + test ax,2 + jnz .list_end + mov si,space_message + call print_string + push cx + push bx + CAR(bx, bx) + xor dx,dx + call print_object + pop bx + pop cx + CDR(bx, bx) + jmp .list_loop + + .list_end: + or bx,bx + jz .list_close + mov si,dot_message + call print_string + xor dx,dx + call print_object + + .list_close: + mov si,list_end_message + call print_string + ret + + .depth_limit_reached: + mov si,depth_limit_reached_message + jmp print_string + +; bx - string list +print_string_list: + or bx,bx + jz .done + mov si,.buffer + mov al,[gs:bx+2] + mov [si+0],al + mov al,[gs:bx+3] + mov [si+1],al + mov al,[gs:bx+4] + mov [si+2],al + mov al,[gs:bx+5] + mov [si+3],al + mov al,[gs:bx+6] + mov [si+4],al + mov al,[gs:bx+7] + mov [si+5],al + call print_string + STRING_NEXT(bx, bx) + jmp print_string_list + .done: + ret + .buffer: db 0,0,0,0,0,0,0 + +clear_screen: + mov ax,0xB800 + mov es,ax + mov ax,SCREEN_COLOR + mov cx,80 * 25 + xor di,di + rep stosw + ret + +output_null: + ret + +terminal_print_string: + .loop: + lodsb + or al,al + jz .done + push si + call terminal_print_character + pop si + jmp .loop + .done: + call update_caret + ret + +; al - character +print_character: + pusha + mov [.buffer],al + mov si,.buffer + call [print_callback] + popa + ret + .buffer: dw 0 + +; si - zero-terminated string +; bp - all list (if print callback is not to the terminal) +; preserves all registers +print_string: + pusha + call [print_callback] + popa + ret + +update_caret: + mov ax,[caret_row] + mov dx,80 + mul dx + add ax,[caret_column] + mov bx,ax + mov dx,0x03D4 + mov al,0x0F + out dx,al + mov dx,0x03D5 + mov al,bl + out dx,al + mov dx,0x03D4 + mov al,0x0E + out dx,al + mov dx,0x03D5 + mov al,bh + out dx,al + ret + +; al - character +terminal_print_character: + mov cx,0xB800 + mov es,cx + cmp al,10 + je .newline + mov cx,ax + call get_caret_position + mov ax,cx + mov [es:bx],al + mov al,[output_color] + mov [es:bx + 1],al + mov bx,[caret_column] + inc bx + cmp bx,79 + je .newline + mov [caret_column],bx + ret + + .newline: + mov bx,1 + mov [caret_column],bx + mov bx,[caret_row] + inc bx + cmp bx,25 + je .scroll + mov [caret_row],bx + ret + + .scroll: + mov bx,[user_input_start] + sub bx,160 + mov [user_input_start],bx + mov bx,[previously_unmatched_brace] + or bx,bx + jz .e1 + sub bx,160 + mov [previously_unmatched_brace],bx + .e1: + mov cx,80 * 24 + mov si,160 + mov di,0 + .scroll_loop: + mov ax,[es:si] + mov [es:di],ax + add si,2 + add di,2 + loop .scroll_loop + mov ax,SCREEN_COLOR + mov cx,80 + rep stosw + ret + +print_backspace: + mov ax,[caret_column] + cmp ax,1 + je .up + dec ax + mov [caret_column],ax + jmp update_caret + .up: + mov word [caret_column],78 + dec word [caret_row] + jmp update_caret + +; ax - int to print +; preserves registers +print_s16: + pusha + cmp ax,0 + jg .positive + je .zero + push ax + mov al,'-' + call print_character + pop ax + neg ax + .positive: + mov si,.buffer + 4 + .divide_loop: + or ax,ax + jz .done + xor dx,dx + mov cx,10 + div cx + add dl,'0' + mov [si],dl + dec si + jmp .divide_loop + .done: + inc si + call print_string + popa + ret + .zero: + mov al,'0' + call print_character + popa + ret + .buffer: db 0, 0, 0, 0, 0, 0 + +; ax - word to print in hex +; preserves registers +print_word: + pusha + mov cx,ax + mov bx,cx + shr bx,12 + and bx,15 + mov al,[hex_characters + bx] + push cx + call print_character + pop cx + mov bx,cx + shr bx,8 + and bx,15 + mov al,[hex_characters + bx] + push cx + call print_character + pop cx + mov bx,cx + shr bx,4 + and bx,15 + mov al,[hex_characters + bx] + push cx + call print_character + pop cx + mov bx,cx + and bx,15 + mov al,[hex_characters + bx] + call print_character + popa + ret + +; preserves registers +print_newline: + pusha + mov al,10 + call print_character + popa + ret + +initialize_io: + ; Get drive parameters. + mov ah,0x08 + mov dl,[drive_number] + xor di,di + int 0x13 + jc error_io_fatal + and cx,31 + mov [max_sectors],cx + inc dh + shr dx,8 + mov [max_heads],dx + + ; Load the filesystem header. + mov ax,ds + mov es,ax + mov di,1 + mov bx,FS_HEADER_BUFFER + call read_sector + jc error_io_fatal + + ; Check for correct signature and version. + mov ax,[FS_HEADER_BUFFER] + cmp ax,0x706C + jne error_io_fatal + mov ax,[FS_HEADER_BUFFER + 2] + cmp ax,1 + jne error_io_fatal + + ret + +; di - LBA. +; es:bx - buffer +; returns carry set on error +read_sector: + xor si,si + jmp access_sector + +; di - LBA. +; es:bx - buffer +; returns carry set on error +write_sector: + mov si,1 + jmp access_sector + +; di - LBA. +; es:bx - buffer +; si - 1 to write, 0 to read +; returns carry set on error +access_sector: + mov byte [read_attempts],5 + + .try_again: + + mov al,[read_attempts] + or al,al + jz .error + dec byte [read_attempts] + + ; Calculate cylinder and head. + mov ax,di + xor dx,dx + div word [max_sectors] + xor dx,dx + div word [max_heads] + push dx ; remainder - head + mov ch,al ; quotient - cylinder + shl ah,6 + mov cl,ah + + ; Calculate sector. + mov ax,di + xor dx,dx + div word [max_sectors] + inc dx + or cl,dl + + ; Access the sector. + pop dx + mov dh,dl + mov dl,[drive_number] + push si + or si,si + jz .read + mov ax,0x0301 + int 0x13 + jmp .done_int + .read: + mov ax,0x0201 + int 0x13 + .done_int: + pop si + jc .try_again + + clc + ret + .error: + stc + ret + +; preserves bx, cx, dx, di, bp +start_reading_root_directory: + mov word [ROOT_HANDLE + 0],0xFFFF ; position in root directory (invalid) + mov ax,[FS_HEADER_BUFFER + 12 + 16] + mov [ROOT_HANDLE + 2],ax ; file size (low) + mov ax,[FS_HEADER_BUFFER + 12 + 18] + mov [ROOT_HANDLE + 4],ax ; file size (high) + mov word [ROOT_HANDLE + 6],0 ; offset into sector + mov ax,[FS_HEADER_BUFFER + 12 + 20] + mov [ROOT_HANDLE + 8],ax ; current sector + mov ax,1 + mov [ROOT_HANDLE + 10],ax ; access mode + mov si,ROOT_HANDLE + pusha + call read_first_file_sector + popa + ret + +; si - zero-terminated filename +; dx - 1 for read mode, 2 for write mode, 3 for append mode +; read/append fails if file doesn't exist, write creates or truncates +; returns file handle in si, or 0xFFFF if not found/on error +open_file: + ; Check the filename is between 1 and 15 bytes. + mov di,si + .check_length: + lodsb + or al,al + jz .got_length + jmp .check_length + .got_length: + mov cx,si + sub cx,di + cmp cx,16 + ja .error + or cx,cx + jz .error + mov [.name_length],cx + mov [.name],di + mov [.access_mode],dx + + ; Setup the last file handle for reading the root directory. + call start_reading_root_directory + jc .error + + mov word [.first_unused],0xFFFF + + ; Loop through each entry of the root directory. + .directory_loop: + mov ax,[ROOT_HANDLE + 8] + mov [.previous_sector],ax + mov si,ROOT_HANDLE + mov cx,0x20 + mov bx,ds + mov es,bx + mov di,.directory_entry + call read_file + cmp cx,0x20 + jb .not_found + call has_error_file + jc .error + + ; Is the entry in use? + cmp byte [.directory_entry],0 + jne .in_use + mov ax,[FS_HEADER_BUFFER + 12 + 16] + sub ax,[ROOT_HANDLE + 2] + sub ax,0x20 ; ...since the file pointer is now one past this entry + and ax,0x1FF + mov [.first_unused],ax + mov ax,[.previous_sector] + mov [.first_unused_sector],ax + jmp .directory_loop + + ; Compare the filenames. + .in_use: + mov ax,ds + mov es,ax + mov cx,[.name_length] + mov si,[.name] + mov di,.directory_entry + rep cmpsb + jne .directory_loop + + ; Calculate the position of the file in the root directory. + ; The root directory cannot exceed 64KB, so we ignore the high file size. + mov ax,[FS_HEADER_BUFFER + 12 + 16] + sub ax,[ROOT_HANDLE + 2] + sub ax,0x20 ; ...since the file pointer is now one past this entry + + ; Check the file isn't already open, and note the first available handle. + mov cx,MAX_OPEN_FILES + mov si,open_file_table + mov di,0xFFFF + .check_not_open_loop: + cmp word [si + 10],0 + je .not_in_use + cmp [si + 0],ax + je .error ; already open + jmp .next_open_check + .not_in_use: + mov di,si + .next_open_check: + add si,DATA_PER_OPEN_FILE + loop .check_not_open_loop + + ; Were there any available handles? + cmp di,0xFFFF + je .error + + ; Save the file information to the handle table. + mov [di + 0],ax ; position in root directory + mov ax,[.directory_entry + 16] + mov [di + 2],ax ; file size low + mov ax,[.directory_entry + 18] + mov [di + 4],ax ; file size high + mov word [di + 6],0 ; offset into sector + mov ax,[.directory_entry + 20] + mov [di + 8],ax ; current sector + + mov si,di + + ; If opening the file in write or delete mode, truncate the file. + cmp word [.access_mode],FILE_READ + je .not_truncate + cmp word [.access_mode],FILE_RENAME + je .not_truncate + cmp word [.access_mode],FILE_APPEND + je .not_truncate + mov ax,[si + 2] + or ax,[si + 4] + or ax,ax + jz .not_truncate ; the file size is zero, no need to truncate + xor ax,ax + mov [si + 2],ax ; file size = 0 + mov [si + 4],ax + mov ax,[si + 8] + push si + xor dx,dx + cmp word [.access_mode],FILE_DELETE + je .truncate_all + inc dx + .truncate_all: + call free_file_sectors + pop si + jc .error + .not_truncate: + + ; If opening the file in append mode, seek to the end of the file. + cmp word [.access_mode],FILE_APPEND + jne .not_append + mov cx,[si + 2] + shr cx,9 + mov dx,[si + 4] + shl dx,7 + or cx,dx + .seek_loop: + or cx,cx + jz .seek_done + push cx + push si + xor cx,cx ; we read the sector in read_first_file_sector below + call read_next_file_sector + pop si + pop cx + jc .error + dec cx + jmp .seek_loop + .seek_done: + mov cx,[si + 2] + and cx,511 + mov [si + 6],cx + .not_append: + + ; If reading or appending, load the current sector. + cmp word [.access_mode],FILE_WRITE + je .skip_load_current_sector + cmp word [.access_mode],FILE_RENAME + je .skip_load_current_sector + cmp word [.access_mode],FILE_DELETE + je .skip_load_current_sector + push si + call read_first_file_sector + pop si + jc .error + .skip_load_current_sector: + + ; Return the file handle. + mov ax,[.access_mode] + mov [si + 10],al ; access mode + mov al,[.directory_entry + 23] + mov [si + 11],al ; checksum + ret + + ; The file was not found. + .not_found: + cmp word [.access_mode],FILE_READ + je .error + cmp word [.access_mode],FILE_RENAME + je .error + cmp word [.access_mode],FILE_DELETE + je .error + + ; Have we seen an unused entry to put the file in? + mov ax,[.first_unused] + cmp ax,0xFFFF + je .append_entry + mov ax,[.first_unused_sector] + mov [ROOT_HANDLE + 8],ax + call read_first_file_sector + mov bx,[.first_unused] + jmp .create_entry + + .append_entry: + + ; Is there room in the last sector of the directory? + mov bx,[ROOT_HANDLE + 6] + cmp bx,0x200 + jne .grown + mov si,ROOT_HANDLE + call grow_file + mov bx,[ROOT_HANDLE + 6] + or bx,bx + jnz error_unknown + .grown: + + ; Update the root directory's size in the header sector. + push bx + add word [FS_HEADER_BUFFER + 12 + 16],0x20 + mov di,1 + mov ax,ds + mov es,ax + mov bx,FS_HEADER_BUFFER + call write_sector + pop bx + jc .error + + ; Create the new entry. + .create_entry: + add bx,OPEN_FILE_BUFFER + SECTOR_SIZE * 7 + call create_directory_entry + jc .error + + ; Save the directory. + mov di,[ROOT_HANDLE + 8] + mov ax,ds + mov es,ax + mov bx,OPEN_FILE_BUFFER + SECTOR_SIZE * 7 + call write_sector + jc .error + + jmp .retry + + ; Try to open the file again. + .retry: + mov si,[.name] + mov dx,[.access_mode] + jmp open_file + + .error: + mov si,0xFFFF + ret + + .directory_entry: times 0x20 db 0 + .name_length: dw 0 + .name: dw 0 + .access_mode: dw 0 + .first_unused: dw 0 + .first_unused_sector: dw 0 + .previous_sector: dw 0 + +; ax - first sector +; dx - the new table value for the first sector (i.e. 0 frees the whole file, 1 frees all but the first sector) +; carry set on error +free_file_sectors: + ; Switch the sector table. + mov bx,ax + shr ax,8 + push bx + push dx + call switch_sector_table + pop dx + pop bx + jc .done + + ; Write the updated entry. + and bx,255 + shl bx,1 + mov ax,[SECTOR_TABLE_BUFFER + bx] + mov [SECTOR_TABLE_BUFFER + bx],dx + mov byte [sector_table_modified],1 + + ; Free the next sector. + xor dx,dx + cmp ax,1 + jne free_file_sectors + clc + .done: ret + +; bx - destination +; carry set on error +create_directory_entry: + mov ax,ds + mov es,ax + + ; Clear the entry. + mov cx,0x20 + xor al,al + mov di,bx + rep stosb + + ; Save the file name. + mov si,[open_file.name] + mov cx,[open_file.name_length] + mov di,bx + rep movsb + + ; Allocate the first sector. + push bx + call allocate_sector ; sets carry on error (returned) + pop bx + mov [bx + 20],ax + ret + +; returns allocated sector in ax +; carry set if disk full or error +allocate_sector: + ; Search the currently loaded table sector. + cmp byte [current_sector_table],0xFF + je .skip_initial_search + call .search_table_sector + jnc .done + + ; Try other table sectors. + .skip_initial_search: + mov byte [.current_search_table],0 + .table_loop: + mov al,[.current_search_table] + call switch_sector_table + jc .error + call .search_table_sector + jnc .done + .next_table: + mov ax,[FS_HEADER_BUFFER + 8] + dec ax + mov bl,[.current_search_table] + cmp al,bl + je .error + inc bl + mov [.current_search_table],bl + jmp .table_loop + + .error: + stc + ret + + .current_search_table: db 0 + + ; Search the loaded sector table sector for a free sector. + .search_table_sector: + mov cx,256 ; 512 byte sector, 2 bytes per entry + mov bx,SECTOR_TABLE_BUFFER + .search_loop: + cmp word [bx],0 + jz .search_found + add bx,2 + loop .search_loop + stc + ret + + ; Update the table. + .search_found: + mov ax,bx + shr ax,1 + mov ah,[current_sector_table] + mov word [bx],1 ; end of file + mov byte [sector_table_modified],1 + ret + + .done: + ret + +; sets carry on error +save_sector_table: + cmp byte [sector_table_modified],0 + je .done + mov byte [sector_table_modified],0 + xor ah,ah + mov al,[current_sector_table] + mov di,ax + add di,2 + mov ax,ds + mov es,ax + mov bx,SECTOR_TABLE_BUFFER + jmp write_sector + .done: ret + +; si - file handle +; carry set on error +flush_current_sector: + call get_file_buffer_offset + mov di,[si + 8] ; current sector + mov ax,ds + mov es,ax + jmp write_sector + +; si - file handle +close_file: + ; Were we writing to this file? + cmp byte [si + 10],FILE_READ + je .done + + ; Don't flush the file if we only opened it to rename or delete it. + cmp byte [si + 10],FILE_RENAME + je .skip_flush + cmp byte [si + 10],FILE_DELETE + je .skip_flush + + ; We need to flush the file. + push si + call flush_current_sector + pop si + .skip_flush: + + ; Seek to the correct sector in the root directory. + mov cx,[si + 0] ; position in root directory + shr cx,9 ; get sector in root directory + push si + call start_reading_root_directory + jc .done + or cx,cx + jz .no_seek + .find_directory_entry_loop: + push cx + mov si,ROOT_HANDLE + call read_next_file_sector ; cx = 1 on last iteration, which loads sector + pop cx + jc .pop + loop .find_directory_entry_loop + .no_seek: + pop si + + ; Update the directory entry. + mov bx,[si + 0] + and bx,511 ; get position within root directory sector + mov cx,[si + 2] ; file size low + mov [bx + OPEN_FILE_BUFFER + SECTOR_SIZE * 7 + 16],cx + mov cx,[si + 4] ; file size high + mov [bx + OPEN_FILE_BUFFER + SECTOR_SIZE * 7 + 18],cx + mov cl,[si + 11] ; checksum + mov [bx + OPEN_FILE_BUFFER + SECTOR_SIZE * 7 + 23],cl + + ; Rename the file, if necessary. + cmp byte [si + 10],FILE_RENAME + jne .skip_rename + mov ax,[next_filename_argument.name + 0] + mov [bx + OPEN_FILE_BUFFER + SECTOR_SIZE * 7 + 0],ax + mov ax,[next_filename_argument.name + 2] + mov [bx + OPEN_FILE_BUFFER + SECTOR_SIZE * 7 + 2],ax + mov ax,[next_filename_argument.name + 4] + mov [bx + OPEN_FILE_BUFFER + SECTOR_SIZE * 7 + 4],ax + mov ax,[next_filename_argument.name + 6] + mov [bx + OPEN_FILE_BUFFER + SECTOR_SIZE * 7 + 6],ax + mov ax,[next_filename_argument.name + 8] + mov [bx + OPEN_FILE_BUFFER + SECTOR_SIZE * 7 + 8],ax + mov ax,[next_filename_argument.name + 10] + mov [bx + OPEN_FILE_BUFFER + SECTOR_SIZE * 7 + 10],ax + mov ax,[next_filename_argument.name + 12] + mov [bx + OPEN_FILE_BUFFER + SECTOR_SIZE * 7 + 12],ax + mov ax,[next_filename_argument.name + 14] + mov [bx + OPEN_FILE_BUFFER + SECTOR_SIZE * 7 + 14],ax + .skip_rename: + + ; Delete the entry, if necessary. + cmp byte [si + 10],FILE_DELETE + jne .skip_delete + mov byte [bx + OPEN_FILE_BUFFER + SECTOR_SIZE * 7 + 0],0 + .skip_delete: + + ; Write out the directory entry. + push si + mov si,ROOT_HANDLE + call flush_current_sector + + ; Finally, save the sector table (if it was modified). + call save_sector_table + + .pop: + pop si + .done: + mov word [si + 10],0 ; clear access mode + ret + +; si - file handle +; carry set if file handle has error flag set +; everything preserved +has_error_file: + test word [si + 10],FILE_ERROR + jz .no_error + stc + ret + .no_error: + clc + ret + +; si - file handle (preserved) +; offset returned in bx +; additionally preserves di and es +get_file_buffer_offset: + mov ax,si + sub ax,open_file_table + mov cx,DATA_PER_OPEN_FILE + xor dx,dx + div cx + mov cx,0x200 + mul cx + mov bx,OPEN_FILE_BUFFER + add bx,ax + ret + +; si - file handle (preserved) +; cx - bytes to write +; es:di - source +; may set error flag on handle +write_file: + or cx,cx + jz .done + + ; Check error flag has not been set. + mov al,[si + 10] + test al,FILE_ERROR + jnz .done + + ; Get the file buffer to use. + push cx + call get_file_buffer_offset + mov dx,bx + pop cx + + .loop: + + ; Work out how many bytes we can write this iteration. + ; We are limited by the buffer size (a sector), + ; and the amount of requested bytes to write. + mov ax,cx + mov bx,0x200 + sub bx,[si + 6] ; offset into sector + cmp bx,ax ; is remaining data in buffer limiting? + ja .e1 + mov ax,bx + .e1: + or ax,ax + jz .nothing_to_write + + ; Write data to the buffer. + mov bl,[si + 11] ; checksum + push cx + push si + push ax + mov cx,ax + mov si,[si + 6] + add si,dx + .write_loop: + mov al,[es:di] + mov [si],al + inc si + inc di + xor bl,al + loop .write_loop + pop ax + pop si + pop cx + mov [si + 11],bl + + ; Update position in buffer, file size and remaining bytes to read. + add [si + 6],ax + add [si + 2],ax + adc word [si + 4],0 + sub cx,ax + + .nothing_to_write: + ; If we are at the end of the buffer, then write the sector and allocate the next. + cmp word [si + 6],0x200 + jne .sector_unfinished + mov ax,es + push ax + push cx + push dx + push di + push si + call flush_current_sector + pop si + jc .flush_failed + call grow_file + .flush_failed: + pop di + pop dx + pop cx + pop es + jc .error + .sector_unfinished: + + ; Have we written all the requested data yet? + or cx,cx + jnz .loop + + .done: + ret + .error: + or byte [si + 10],FILE_ERROR + jmp .done + +; si - file handle (preserved) +; sets carry on error +grow_file: + ; Allocate a new sector. + push si + call allocate_sector + pop si + jc .done + + ; Store the new sector. + mov bx,[si + 8] ; previous sector + mov [si + 8],ax ; current sector + + ; Link sector into file. + mov ax,bx + shr ax,8 ; sector table index + push si + push bx + call switch_sector_table + pop bx + pop si + jc .done + and bx,0xFF + mov ax,[si + 8] + shl bx,1 + mov [bx + SECTOR_TABLE_BUFFER],ax + mov byte [sector_table_modified],1 + jc .done + mov word [si + 6],0 + + clc + .done: + ret + +; al - new sector table index +; sets carry on error +switch_sector_table: + cmp al,[current_sector_table] + je .skip_switch + + ; Save the previous sector table (if it was modified). + push ax + call save_sector_table + pop ax + mov [current_sector_table],al + + ; Load the new sector table buffer. + xor ah,ah + add ax,2 + mov di,ax + mov bx,ds + mov es,bx + mov bx,SECTOR_TABLE_BUFFER + call read_sector + jc .error + + .skip_switch: + clc + ret + + .error: + mov byte [current_sector_table],0xFF + stc + ret + +; si - file handle (preserved) +; cx - bytes to read +; es:di - destination +; returns bytes read in cx, may set error flag on handle +read_file: + mov word [.bytes_read],0 + + or cx,cx + jz .done + + ; Check error flag has not been set. + mov al,[si + 10] + cmp al,FILE_READ + jne .done + + ; Get the file buffer to use. + push cx + call get_file_buffer_offset + mov dx,bx + pop cx + + .loop: + + ; Work out how many bytes we can read this iteration. + ; We are limited by the buffer size (a sector), + ; the amount of data left in the file, + ; and the amount of requested bytes to read. + mov ax,cx + cmp word [si + 4],0 ; is high file remaining non-zero? + jne .e1 + cmp word [si + 2],ax ; is low file remaining limiting? + ja .e1 + mov ax,[si + 2] + .e1: + mov bx,0x200 + sub bx,[si + 6] ; offset into sector + cmp bx,ax ; is remaining data in buffer limiting? + ja .e2 + mov ax,bx + .e2: + + ; Read data from the buffer. + push cx + push si + mov cx,ax + mov si,[si + 6] + add si,dx + rep movsb + pop si + pop cx + + ; Update bytes read, position in buffer, remaining bytes in file and remaining bytes to read. + add [.bytes_read],ax + add [si + 6],ax + sub [si + 2],ax + sbb word [si + 4],0 + sub cx,ax + + ; If we are at the end of the file, then exit. + cmp word [si + 2],0 + jne .not_at_end + cmp word [si + 4],0 + je .done + .not_at_end: + + ; If we are at the end of the buffer, then read the next sector. + cmp word [si + 6],0x200 + jne .sector_unfinished + mov ax,es + push ax + push cx + push dx + push si + push di + mov cx,1 + call read_next_file_sector + pop di + pop si + pop dx + pop cx + pop es + jc .error + mov word [si + 6],0 + .sector_unfinished: + + ; Have we read all the requested data yet? + or cx,cx + jnz .loop + + .done: + mov cx,[.bytes_read] + ret + .error: + or byte [si + 10],FILE_ERROR + jmp .done + .bytes_read: dw 0 + +; si - file handle +; carry set on error +read_first_file_sector: + call get_file_buffer_offset + mov di,[si + 8] + mov ax,ds + mov es,ax + jmp read_sector + +; si - file handle +; cx - **1** if you want to read the sector +; carry set on error +read_next_file_sector: + push si + push cx + + ; Do we need to switch the sector table buffer? + mov ax,[si + 8] ; current sector + shr ax,8 ; 256 sector table entries per sector + call switch_sector_table + jc .error_table + + pop cx + pop si + + ; Get the next sector. + mov bx,[si + 8] ; current sector + and bx,0xFF + shl bx,1 + mov di,[SECTOR_TABLE_BUFFER + bx] + mov [si + 8],di + + ; If we're just seeking through the file, we don't need to read the sector. + cmp cx,1 + jne .skip_load + + ; Load the next sector. + mov bx,ds + mov es,bx + call get_file_buffer_offset + jmp read_sector + + .skip_load: + clc + ret + + .error_table: + pop si + stc + ret + +; --------------- Global state. + +recover: + dw 0 + +first_free_string: + dw 0 +first_free_object: + dw 0 +obj_symbol_table: + dw 0 +obj_builtins: + dw 0 +gc_ready: + db 0 + +next_character: + dw 0 +input_handle: + dw 0 +input_line: + dw 0 +input_offset: + dw 0 + +print_callback: + dw terminal_print_string +print_data: + dw 0 + +drive_number: + db 0 +read_attempts: + db 0 +max_sectors: + dw 0 +max_heads: + dw 0 + +current_sector_table: + db 0xFF +sector_table_modified: + db 0 + +caret_column: + dw 1 +caret_row: + dw 0 +output_color: + dw (SCREEN_COLOR >> 8) +graphics_mode: + dw 0 + +user_input_start: + dw 0 +previously_unmatched_brace: + dw 0 + +check_break: + db 0 +last_scancode: + db 0 + +open_file_table: + times (MAX_OPEN_FILES * DATA_PER_OPEN_FILE) db 0 + +; --------------- Constants. + +loading_message: + db 'initializing... ',0 +hex_characters: + db '0123456789ABCDEF' +prompt_message: + db 10,'flip> ',0 +unknown_type_message: + db '',0 +nil_message: + db 'nil',0 +builtin_message: + db '',0 +string_quote_message: + db '"',0 +list_start_message: + db '[',0 +depth_limit_reached_message: + db '...]',0 +list_end_message: + db ']',0 +dot_message: + db ' . ',0 +space_message: + db ' ',0 +kilobytes_message: + db 'K',0 +bytes_message: + db 'B',0 +total_usage_message: + db 'Disk space usage: ',0 +out_of_message: + db ' of ',0 +memory_usage_message: + db 'Memory usage: ',0 + +startup_command: + db '[src "startup.lisp"]',0 +startup_command_length: + db 21 +run_startup_command: + db 0 + +builtin_strings: + db 'nil',0 + db '+',0 + db '-',0 + db '*',0 + db '/',0 + db 'mod',0 + db '<',0 + db '<=',0 + db '>',0 + db '>=',0 + db 'is',0 + db 'atom',0 + db 'not',0 + db 'and',0 + db 'or',0 + db 'car',0 + db 'cdr',0 + db 'cons',0 + db 'setcar',0 + db 'setcdr',0 + db 'list',0 + db 'do',0 + db 'if',0 + db 'while',0 + db 'let',0 + db '=',0 + db 'q',0 + db 'fun',0 + db 'mac',0 + db 'print',0 + db 'print-col',0 + db 'print-substr',0 + db 'poke',0 + db 'peek',0 + db 'src',0 + db 'read',0 + db 'write',0 + db 'append',0 + db 'rename',0 + db 'annul',0 + db 'dir',0 + db 'ls',0 + db 'terminal',0 + db 'strlen',0 + db 'nth-char',0 + db 'capture',0 + db 'capture-upper',0 + db 'capture-lower',0 + db 'set-graphics',0 + db 'wait-key',0 + db 'muldiv',0 + db 'env-reset',0 + db 'env-list',0 + db 'env-export',0 + db 'env-import',0 + db 'inspect',0 + db 'pause',0 + db 'last-scancode',0 + db 'random',0 + db 'outb',0 + db 0 +builtin_functions: + dw 0 ; nil + dw do_builtin_add + dw do_builtin_subtract + dw do_builtin_multiply + dw do_builtin_divide + dw do_builtin_modulo + dw do_builtin_lt + dw do_builtin_lte + dw do_builtin_gt + dw do_builtin_gte + dw do_builtin_is + dw do_builtin_atom + dw do_builtin_not + dw do_builtin_and + dw do_builtin_or + dw do_builtin_car + dw do_builtin_cdr + dw do_builtin_cons + dw do_builtin_setcar + dw do_builtin_setcdr + dw do_builtin_list + dw do_builtin_do + dw do_builtin_if + dw do_builtin_while + dw do_builtin_let + dw do_builtin_set + dw do_builtin_quote + dw do_builtin_lambda + dw do_builtin_macro + dw do_builtin_print + dw do_builtin_print_colored + dw do_builtin_print_substr + dw do_builtin_poke + dw do_builtin_peek + dw do_builtin_src + dw do_builtin_read + dw do_builtin_write + dw do_builtin_append + dw do_builtin_rename + dw do_builtin_delete + dw do_builtin_dir + dw do_builtin_ls + dw do_builtin_terminal + dw do_builtin_strlen + dw do_builtin_nth_char + dw do_builtin_capture + dw do_builtin_capture_upper + dw do_builtin_capture_lower + dw do_builtin_set_graphics + dw do_builtin_wait_key + dw do_builtin_muldiv + dw do_builtin_env_reset + dw do_builtin_env_list + dw do_builtin_env_export + dw do_builtin_env_import + dw do_builtin_inspect + dw do_builtin_pause + dw do_builtin_last_scancode + dw do_builtin_random + dw do_builtin_outb