From 875e32590c95038f9e51a2137e6059889acdcddb Mon Sep 17 00:00:00 2001 From: Nakst Date: Sun, 12 Jul 2020 16:26:11 +0100 Subject: [PATCH] Add files via upload --- boot.s | 270 +++ build.sh | 29 + mandelbrot.lisp | 40 + mkfs.c | 120 ++ snake.lisp | 230 +++ startup.lisp | 15 + system.s | 5079 +++++++++++++++++++++++++++++++++++++++++++++++ 7 files changed, 5783 insertions(+) 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/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