; ; A BOOTABLE FORTH STYLE "OS" ; ; This file represents a working bootable readonly forth-like system. ; It uses a byte-code approach to creating a simple forth dictionary. ; Its overall aim is to create a portable and minimal booting ; interactive system. All commands entered interactively are ; 'compiled' into bytecode into a special interpretive buffer and ; then executed. ; ; Even "proceedures" (everything after the no-op procedure) are ; written in pseudo forth. That means that they are just a series ; of calls - to opcodes and other proceedures. The idea behind that ; is to make porting to another architecture simpler. ; ; Also, the general aim of the code is to get to a source interpreter ; and compiler in the minimum code size possible. ; ; As in all forths the "accept" word takes input from the user and ; puts that input into a buffer. The backspace key can be used to ; edit the user input. ; ; This is by no means a standard forth! It is an experiment. ; ; FEATURES ; ; Unlike some forths, this version compiles commands entered ; interactively to an anonymous buffer. The advantage of this is that ; flow control words like if, fi, else, begin, until... can be ; used interactively, not just in colon : definitions. ; ; Bytecode. ; ; STRUCTURE OF THE DICTIONARY ; ; One of the key ideas of a forth-like system is the use of a ; linked list with each item in the list being a data structure ; with the name and code for a particular function. This linked list ; is called the dictionary. The current code uses the following ; structure for the dictionary: ; ; [link to previous word] 2 bytes ; [name of word] [count of name] ; [count of name] 1 byte || IMMEDIATE FLAG ; [code] ; ; using reverse name counts. This allows us to decompile ; byte code by getting a list of pointers to code and ; then looking up name ; eg ; db 'minus', 5 ; dw exec ; link to previous ; ; Another refinement is to hold the top element of the ; stack in ax, which simplifies a lot of stack manipulation. ; eg 1+ becomes "inc ax" etc. But I found this also introduced ; complications. ; ; CULTURE ; ; Forth has its own culture. It uses a set of words and concepts ; which are completely different from the main stream coding ; world. These days forth is a forgotten backwater with almost ; no mainstream relevance, but its ideas remain powerful. ; ; ; INSPIRATION ; ; The code was original inspired by the helpful and simple instructions ; from MikeOS on how to get a minimal booting x86 "operating system" ; working. The code was also inspired by the incredible simplicity ; of forth-like systems, and also, the ease of implementing a bytecode ; system using indirect jumps. ; ; In general, simplicity appears to be much more fertile than ; complexity. Linus Torvalds was inspired by the simplicity of ; Tannenbaum's minix system to start the Linux journey. ; ; IMMEDIATE WORDS ; ; One of the main semantic problems of forth systems is the ; idea of immediate vs non-immediate words. Immediate words ; execute at compile-time and non-immediate words execute ; at run-time. These ideas occur because forth is a compiling ; system ; ; eg char " ; puts the character " (integer 34) on the stack at run-time ; but [char] " or [ char ] " ; does the same thing at compile time ; ; TO DO (may 2018): ; ; * combine "source" and "inputcompile". ; * get "load" to work. ; * rewrite some words as "source" now that the : compiler ; more or less works. ; * find out what words are really necessary for the : word ; * load a "block" or 2 sectors (1024 bytes) from the disk, or ; emulated disk (usb memory). ; * it would be good to be able to add new "opcodes" dynamically ; to allow for the situation where new hardware becomes or is ; available. For example, if a gyroscope is available, then ; extended opcodes should read data from it. ; ; * perhaps a "domain" field in the dictionary with a lookup list ; so that all names in the dictionary will be universally unique. ; eg a = core.math. b = net.tcp. etc ; then in each word a domain field a/b/c which gets attached to ; the name to make a full name. eg core.math.squareroot etc ; * "dictionary full" check, ie. is there any more memory in which ; to place new words? ; * stack underflow check? ; * read/write sector block to memory ; * implement block and buffer. Buffer writes to disk and frees ; a buffer and block reads from disk. block call buffer ; * the inputcompile.p word is really the same as the "source.p" word ; ; ; MEMORY MAP ; ; The way that the code and data is laid out in memory is ; important. The bootloading segment (512 bytes) loads more ; code into memory (a few K) and then jumps to the entry point. ; When the code dictionary grows (by the use of new colon : ; definitions) the new dictionary entries should be placed in ; memory after the end of the dictionary. ; ; The data and return stack (ES:DI) ; Further source code can ; CHALLENGES ; ; How to write new code words back to disk? We can either write ; compiled code to disk as part of the dictionary, or just write ; source code to disk in forth-style "blocks". This is potentially ; dangerous, if we accidentally write to the computer hard disk ; we may corrupt the file system or even the operating system! ; ; We must write the dictionary or source code back into the ; usb or disk file system, which is not easy. ; ; HOW TO BUILD AND RUN THIS CODE ; ; We can either run the code in a virtual machine like qemu ; or else actually write it to a usb or cd and boot it! ; The simulator is good for testing, but the usb or cd boot ; shows you how it works on real hardware! ; ; tools: nasm, qemu, dd ; ; * compile with nasm into a bootable executable ; nasm -fbin -o os.bin os.asm; ; * make a 1.4Meg floppy image and insert the executable into it. ; sudo rm os.flp; sudo mkdosfs -C os.flp 1440; ; sudo dd status=noxfer conv=notrunc if=os.bin of=os.flp' ; * run the executable floppy image with qemu simulator (VM) ; sudo qemu-system-i386 -fda os.flp' ; ; To "burn" to usb or cd try: ; * unmount the usb memory stick ; umount /dev/sdc ; * write the bootable floppy image to memory stick: WARNING! ; sudo dd if=os.flp of=/dev/sdc ; !! The code above deletes all other files on the memory stick ; Be very very careful that you dont do this to your harddisk ; or you will end up with an unbootable computer. !! ; ; The light should flash on the usb stick indicating that data ; is being written. Then just reboot the computer and choose the ; boot device. I think I had to "enable csm" or "choose floppy" mode ; in my bios to get the usb stick to boot. ; ; Some bash aliases for compiling and running the code. ; ; alias os='sudo qemu-system-i386 -fda os.flp' ; alias cos='nasm -fbin -o os.bin os.asm; sudo rm os.flp; sudo mkdosfs -C os.flp 1440; sudo dd status=noxfer conv=notrunc if=os.bin of=os.flp' ; ; HISTORY ; ; 15 May 2018 ; Finally got a : compiler working, so new words can be added ; to the dictionary. Wrote inputcompile (input,) to compile ; the input buffer to the here pointer. Made a basic foreground ; colour changer just for fun fg.x and a video mode changer vid.x ; 11 May 2018 ; separated this forth-like system into a new file. Up until ; now, have been developing as part of the osdev booklet. ; 10 june 2017 ; made a return stack with es:di and made fcall.x and exit.x ; use the return stack, apparently successfully which allows ; nested procedures. BITS 16 [ORG 0] jmp 07C0h:bootload ; Goto segment 07C0 drive: db 0 ; a variable to hold boot drive number db 'bootload...' bootload: mov ax, cs ; the code segment is already correct (?!) mov ds, ax ; set up data and extended segments mov es, ax mov [drive], dl ; save the boot drive number mov ax, 07C0h ; Set up 4K stack space after this bootloader add ax, 288 ; (4096 + 512) / 16 bytes per paragraph mov ss, ax ; with a 4K gap between stack and code mov sp, 4096 ; save the DL register or else dont modify it ; it contains the number of the boot medium (hard disk, ; usb memory stick etc) ; The 'floppy' Drive is NOT necesarily 0!!! reset: ; Reset the virtual floppy drive (usb) mov ax, 0 ; mov dl, [drive] ; the boot drive number (eg for usb 128) int 13h ; jc reset ; ERROR => reset again read: mov ax, 1000h ; ES:BX = 1000:0000 mov es, ax ; es:bx determines where data loaded to mov bx, 0 ; mov ah, 2 ; Load disk data to ES:BX ;mov al, 8 ; Load 8 sectors 512 bytes * 8 == 4K mov al, 16 ; Load 16 sectors 512 bytes * 16 == 8K mov ch, 0 ; Cylinder=0 mov cl, 2 ; Sector=2 (sector 1 is the boot sector) mov dh, 0 ; Head=0 mov dl, [drive] ; int 13h ; Read! jc read ; ERROR => Try again jmp 1000h:0000 ; Jump to the loaded code times 510-($-$$) db 0 ; pad out the boot sector ; (512 bytes) dw 0AA55h ; end with standard boot signature ; **** ; this below is the magic line to make the new memory offsets ; work. Or compile the 2 files separately ; https://forum.nasm.us/index.php?topic=2160.0 section stage2 vstart=0 jmp start ; aliases for each bytecode, these aliases need to be in the ; same order as the pointer table below ; The nasm code below gives values of 1,2,3,4,5 etc to each ; bytecode alias. A new opcode can be inserted without having ; to update all the following opcodes. DUP equ 1 DROP equ DUP+1 SWAP equ DROP+1 OVER equ SWAP+1 TWODUP equ OVER+1 DEPTH equ TWODUP+1 RDEPTH equ DEPTH+1 RON equ RDEPTH+1 ROFF equ RON+1 STORE equ ROFF+1 STOREPLUS equ STORE+1 FETCH equ STOREPLUS+1 FETCHPLUS equ FETCH+1 CSTORE equ FETCHPLUS+1 CSTOREPLUS equ CSTORE+1 CFETCH equ CSTOREPLUS+1 CFETCHPLUS equ CFETCH+1 COUNT equ CFETCHPLUS ; count is an alias for c@+ EQUALS equ CFETCHPLUS+1 NOTEQUALS equ EQUALS+1 LESSTHAN equ NOTEQUALS+1 ULESSTHAN equ LESSTHAN+1 LIT equ ULESSTHAN+1 LITW equ LIT+1 EMIT equ LITW+1 KEY equ EMIT+1 EKEY equ KEY+1 PLUS equ EKEY+1 MINUS equ PLUS+1 INCR equ MINUS+1 DECR equ INCR+1 NEGATE equ DECR+1 LOGOR equ NEGATE+1 ; logical or LOGXOR equ LOGOR+1 LOGAND equ LOGXOR+1 DIVMOD equ LOGAND+1 TIMESTWO equ DIVMOD+1 MULT equ TIMESTWO+1 UMULT equ MULT+1 FCALL equ UMULT+1 PCALL equ FCALL+1 EXIT equ PCALL+1 LJUMP equ EXIT+1 JUMP equ LJUMP+1 JUMPZ equ JUMP+1 JUMPF equ JUMPZ ; jumpf (false) is an aliase for jumpz JUMPNZ equ JUMPZ+1 JUMPT equ JUMPNZ ; jump-true alias for jump-not-zero RLOOP equ JUMPNZ+1 DIVTWO equ RLOOP+1 LOAD equ DIVTWO+1 ; load a sector from disk SAVE equ LOAD+1 FG equ SAVE+1 ; foreground colour VID equ FG+1 ; video mode NOOP equ VID+1 ; no operation & end marker ;*** control bits and mask IMMEDIATE equ 0b10000000 MASK equ 0b00011111 ; a table of code pointers. The pointers have the ; same offset in ; table as value of the opcode op.table: dw 0, dup.x, drop.x, swap.x, over.x, twodup.x dw depth.x, rdepth.x dw ron.x, roff.x dw store.x, storeplus.x, fetch.x, fetchplus.x dw cstore.x, cstoreplus.x dw cfetch.x, cfetchplus.x dw equals.x, notequals.x, dw lessthan.x, ulessthan.x, lit.x, litw.x dw emit.x, key.x, ekey.x dw plus.x, minus.x, incr.x, decr.x, neg.x dw logor.x, logxor.x, logand.x dw divmod.x, timestwo.x, mult.x, umult.x dw fcall.x, pcall.x, exit.x dw ljump.x, jump.x, jumpz.x, jumpnz.x, rloop.x dw divtwo.x dw load.x, save.x, fg.x, vid.x dw noop.x, -1 ; this is the function which executes the byte codes ; takes a pointer to the code. Jumps are relative to the first ; byte of the jump instruction exec: dw 0 db 'exec', 4 exec.x: ; save the return ip for 'exec' since the code ; below call [op.table+bx] changes the stack and ; registers. Before this technique the same byte ; code would get executed over and over again because ; exec was not returning properly pop word [returnexec] ; save return ip pop si ; get pointer to code .nextopcode: xor ax, ax ; set ax := 0 lodsb ; al := [si]++ cmp al, 0 ; zero marks end of code je .exit .opcode: mov bx, ax ; get opcode (1-6 etc) into bx shl bx, 1 ; double bx because its a word pointer call [op.table+bx] ; use opcode as offset into ; code pointer table ;*** check for stack underflow here ??? jmp .nextopcode .exit: push word [returnexec] ; restore fn return ip ret returnexec dw 0 plus.doc: ; db 'add the top 2 elements of the stack.' ; db ' ( n1 n2 -- n1+n2 ) ' ; db ' This opcode is agnostic about whether the two 16 bit ' ; db ' numbers are signed or unsigned. What should happen in ' ; db ' the case of an overflow ? ' ; db ' eg: LIT, 4, LIT, '0', PLUS, EMIT ' ; db ' displays the digit "4" ' ; dw $-plus.doc plus: dw exec.x db '+', 1 plus.x: pop dx ; juggle return pointer pop bx pop ax add ax, bx push ax push dx ; restore return pointer ret minus.doc: ; db 'subtract the top element of stack from next top' ; db ' ( n1 n2 -- n1-n2 ) ' ; dw $-minus.doc minus: dw plus.x db '-', 1 minus.x: pop dx ; juggle return pointer pop bx pop ax sub ax, bx push ax push dx ; restore return pointer ret incr.doc: ; db ' ( n -- n+1 ) ; db 'Increment the top element of the data ; db 'stack by one. ' ; dw $-incr.doc incr: dw minus.x db '1+', 2 incr.x: pop dx ; juggle return pointer pop ax inc ax push ax push dx ; restore return pointer ret decr.doc: ; db ' ( n -- n-1 ) ; db 'Decrement top element of the data stack by one. ' ; dw $-decr.doc decr: dw incr.x db '1-', 2 decr.x: pop dx ; juggle return pointer pop ax dec ax push ax push dx ; restore return pointer ret neg.doc: ; db ' ( n -- -n ) ; db 'Negates the top item of the stack' ; dw $-neg.doc neg: dw decr.x db 'neg', 3 neg.x: pop dx ; juggle return pointer pop ax neg ax push ax push dx ; restore return pointer ret logor.doc: ; db ' ( n1 n2 -- n1 V n2 ) ; db 'the logical or of n1 and n2' ; dw $-logor.doc logor: dw neg.x db 'or', 2 logor.x: pop dx ; juggle return pointer pop ax pop bx or ax, bx push ax push dx ; restore return pointer ret logxor.doc: ; db ' ( n1 n2 -- n1 V n2 ) ; db 'the logical or of n1 and n2' ; dw $-logxor.doc logxor: dw logor.x db 'xor', 3 logxor.x: pop dx ; juggle return pointer pop ax pop bx xor ax, bx push ax push dx ; restore return pointer ret logand.doc: ; db ' ( n1 n2 -- n1 && n2 ) ; db 'the logical and of n1 and n2' ; dw $-logand.doc logand: dw logxor.x db 'and', 3 logand.x: pop dx ; juggle return pointer pop ax pop bx and ax, bx push ax push dx ; restore return pointer ret divtwo.doc: ; db '(n1 - n1/2) ' ; db ' divide n1 by 2 ' ; dw $-divtwo.doc divtwo: dw logand.x db '/2', 2 divtwo.x: pop dx ; juggle return pointer pop ax ; dividend is next element shr ax, 1 ; do ax := (ax+1)/2 push ax push dx ; restore return pointer ret divmod.doc: ; db '(n1 n2 - remainder quotient) ' ; db ' divide n1 by n2 and provide remainder and quotient. ' ; db ' n2 is the top item on the stack ' ; dw $-divmod.doc divmod: dw divtwo.x db '/mod', 4 divmod.x: pop cx ; juggle return pointer xor dx, dx ; set dx := 0 pop bx ; divisor is top element on stack pop ax ; dividend is next element div bx ; does dx:ax / bx remainder->dx; quotient->ax push dx ; put remainder on stack push ax ; put quotient on top of stack push cx ; restore return pointer ret timestwo.doc: ; db '(n1 -- n1*2 ) ' ; db ' double n1. This basically performs a ' ; db ' left shift on the bits in n1 ' ; dw $-timestwo.doc timestwo: dw divmod.x db '*2', 2 timestwo.x: pop dx ; juggle return pointer pop ax ; dividend is next element shl ax, 1 ; push ax ; push dx ; restore return pointer ret mult.doc: ; db '(n1 n2 -- n1*n2 ) ' ; db ' signed multiplication ' ; dw $-mult.doc mult: dw timestwo.x db '*', 1 mult.x: pop dx ; juggle return pointer pop ax pop bx ; ax * bx ... push ax push dx ; restore return pointer ret umult.doc: ; db '(n1 n2 -- n1*n2 ) ' ; db ' unsigned multiplication ' ; dw $-umult.doc umult: dw mult.x db 'u*', 2 umult.x: pop cx ; juggle return pointer xor dx, dx ; set dx := 0 pop ax pop bx ; ax * bx ... mul bx ; do dx:ax := ax*bx push ax push cx ; restore return pointer ret fcall.doc: ; db 'Call a virtual proceedure on the bytecode ' ; db 'stack machine' ; db 'The current code pointer (in the SI register)' ; db 'is saved - pushed ' ; db 'onto the return stack and the address of the' ; db ' virtual proc ' ; db ' to execute is loaded into SI. ' ; dw $-fcall.doc fcall: dw umult.x db 'fcall', 5 fcall.x: lodsw mov [es:di], si add di, 2 mov si, ax ; adjust the si code pointer ret pcall.doc: ; db ' ( xt -- ) ' ; db ' Call a procedure using the top element on ' ; db ' the data stack as the execution address. This ' ; db ' allows the implementation of function pointers' ; db ' In standard forths this is called "execute". ' ; dw $-pcall.doc pcall: dw fcall.x db 'pcall', 5 ; or call it exec/ex/execute pcall.x: pop dx ; juggle return mov [es:di], si ; save ip to return stack add di, 2 pop si ; get proc exec address from stack push dx ret exit.doc: ; db 'exit a virtual procedure by restoring si ' ; db 'code pointer' ; dw $-exit.doc exit: dw pcall.x db 'exit', 4 exit.x: sub di, 2 mov si, [es:di] ; restore si from rstack ret dup.doc: ; db 'Duplicates the top item on the stack.' ; dw $-dup.doc dup: dw exit.x ; link to previous word db 'dup', 3 ; strings are 'counted' dup.x: pop dx ; juggle fn return address pop ax ; get param to duplicate push ax push ax push dx ; restore fn return address ret drop.doc: ; db 'removes the top item on the stack.' ; dw $-drop.doc drop: dw dup.x ; link to previous word db 'drop', 4 ; strings are 'counted' drop.x: pop dx ; juggle fn return address pop ax ; remove top element of stack push dx ; restore fn return address ret swap.doc: ; db 'swaps the top 2 items on the stack.' ; dw $-swap.doc swap: dw drop.x ; link to previous word db 'swap', 4 swap.x: pop dx ; juggle fn return address pop ax ; get top stack item pop bx ; get next stack item push ax ; put them back on in reverse order push bx push dx ; restore fn return address ret over.doc: ; db ' ( n1 n2 -- n1 n2 n1 ) ' ; db ' Puts a copy of 2nd stack item on top of stack. ' ; db ' dont use this, will probably remove. ' ; dw $-over.doc over: dw swap.x ; link to previous word db 'over', 4 over.x: pop dx ; juggle fn return address pop ax ; get top stack item pop bx ; get next stack item push bx ; push ax ; push bx ; add copy of 2nd item on top of stack push dx ; restore fn return address ret twodup.doc: ; db ' ( n1 n2 -- n1 n2 n1 n2 ) ' ; db ' copies 2 stack items onto stack ' ; dw $-twodup.doc twodup: dw over.x db '2dup', 4 twodup.x: pop dx ; juggle fn return address pop ax ; get top stack item pop bx ; get next stack item push bx ; push ax ; push bx ; push ax ; n1 n2 n1 n2 push dx ; restore fn return address ret depth.doc: ; db ' ( -- n ) ' ; db ' Puts on the stack the number of stack items ' ; db ' before this word was executed ' ; dw $-depth.doc depth: dw twodup.x ; link to previous word db 'depth', 5 depth.x: pop dx ; juggle fn return address mov bx, sp mov ax, 4096 ; 4K stack (but could change!) sub ax, bx ; shr ax, 1 ; div by 2 (2 byte stack cell) ;causing problems ??? ;dec ax ; the exec.x call doesnt count push ax push dx ; restore fn return address ret rdepth.doc: ; db ' ( -- n ) ' ; db ' Puts on the stack the number of stack items ' ; db ' on the return stack before this word ' ; db ' was executed ' ; dw $-rdepth.doc rdepth: dw depth.x db 'rdepth', 6 rdepth.x: pop dx ; juggle fn return address mov ax, di shl ax, 1 push ax push dx ; restore fn return address ret ron.doc: ; db '( S: n -- )( R: -- n ) ' ; db ' put the top item of the data stack onto the return stack.' ; dw $-ron.doc ron: dw rdepth.x db '>r', 2 ron.x: pop dx ; juggle fn return address pop ax ; value to store at address stosw ; [es:di] := ax, di+2 push dx ; restore fn return address ret roff.doc: ; db '( S: -- n)( R: n -- ) ' ; db ' put the top item of the return stack onto the data stack.' ; dw $-roff.doc roff: dw ron.x db 'r>', 2 roff.x: pop dx ; juggle fn return address sub di, 2 ; mov ax, [es:di] ; get top item off return stack push ax push dx ; restore fn return address ret store.doc: ; db '( w adr -- ) ' ; db ' place 2 byte value w at address "adr" ' ; dw $-store.doc store: dw roff.x db '!', 1 store.x: pop dx ; juggle fn return address pop bx ; pointer to address pop ax ; value to store at address mov [bx], ax ; 2 byte is stored push dx ; restore fn return address ret storeplus.doc: ; db '( w adr -- adr+2 ) ' ; dw $-storeplus.doc storeplus: dw store.x ; link to previous word db '!+', 2 storeplus.x: pop dx ; juggle fn return address pop bx ; pointer to address pop ax ; value to store at address mov [bx], ax ; 2 byte value is stored inc bx ; advance address and put on stack inc bx ; advance address and put on stack push bx push dx ; restore fn return address ret fetch.doc: ; db '( adr -- n ) ' ; db ' Replace the top element of the stack with the ' ; db ' value of the 16bites at the given memory address ' ; dw $-fetch.doc fetch: dw storeplus.x ; link to previous word db '@', 1 fetch.x: pop dx ; juggle fn return address pop bx mov ax, word [bx] push ax ; save value on top of stack push dx ; restore fn return address ret fetchplus.doc: ; db '( adr -- adr+2 n ) ' ; db ' Replace the top element of the stack with the ' ; db ' value of the 16bites at the given memory address ' ; db ' and increment the address by 2 bytes. ' ; dw $-fetchplus.doc fetchplus: dw fetch.x ; link to previous word db '@+', 2 fetchplus.x: pop dx ; juggle fn return address pop bx mov ax, word [bx] add bx, 2 ; increment address by 1 word (2 bytes) push bx ; save address on stack push ax ; save value on top of stack push dx ; restore fn return address ret cstore.doc: ; db '( n adr -- ) store the byte value n at address adr.' ; db ' eg: 10 myvar ! ' ; db ' puts the value 10 at the address specified by "myvar" ' ; db ' The address is the top value on the stack. ' ; dw $-cstore.doc cstore: dw fetchplus.x ; link to previous word db 'c!', 2 cstore.x: pop dx ; juggle fn return address pop bx ; pointer to address pop ax ; value to store at address mov [bx], al ; only the low value byte is stored push dx ; restore fn return address ret cstoreplus.doc: ; db '( n adr -- adr+1 ) store the byte value n at address adr.' ; db ' And increment the address ' ; dw $-cstoreplus.doc cstoreplus: dw cstore.x ; link to previous word db 'c!+', 3 cstoreplus.x: pop dx ; juggle fn return address pop bx ; pointer to address pop ax ; value to store at address mov [bx], al ; only the low value byte is stored inc bx ; advance address and put on stack push bx push dx ; restore fn return address ret cfetch.doc: ; db '( adr -- n ) Replace the top element of the stack with the value ' ; db ' of the byte at the given memory address.' ; db ' eg: myvar @ . ' ; db ' displays the value at the address given by "myvar" ' ; dw $-cfetch.doc cfetch: dw cstoreplus.x ; link to previous word db 'c@', 2 cfetch.x: pop dx ; juggle fn return address pop bx xor ax, ax ; set ax := 0 mov al, byte [bx] push ax push dx ; restore fn return address ret cfetchplus.doc: ; db '( adr -- adr+1 n ) ' ; db ' Replace the top element of the stack with the value ' ; db ' of the byte at the given memory address and increment the ' ; db ' address . This is exactly the same as "count"' ; dw $-fetchplus.doc cfetchplus: dw cfetch.x ; link to previous word db 'c@+', 3 cfetchplus.x: pop dx ; juggle fn return address pop bx xor ax, ax ; set ax := 0 mov al, byte [bx] inc bx ; increment address by 1 push bx ; save address on stack push ax ; save value on top of stack push dx ; restore fn return address ret equals.doc: ; db ' ( n1 n2 -- flag ) ' ; db 'Puts -1 (true) on the stack if n1==n2 ' ; db 'otherwise puts zero (false) on the stack. ' ; dw $-equals.doc equals: dw cfetchplus.x ; link to previous word db '=', 1 equals.x: pop dx ; juggle fn return address pop ax ; top stack item pop bx ; 2nd stack item cmp ax, bx je .true .false: push 0 jmp .exit .true: push -1 .exit: push dx ; restore fn return address ret notequals.doc: ; db ' ( n1 n2 -- flag ) ' ; db 'Puts 0 (false) on the stack if n1==n2 ' ; db 'otherwise puts -1 (true) on the data stack' ; dw $-notequals.doc notequals: dw equals.x ; link to previous word db '<>', 2 notequals.x: pop dx ; juggle fn return address pop ax ; top stack item pop bx ; 2nd stack item cmp ax, bx jne .true .false: push 0 jmp .exit .true: push -1 .exit: push dx ; restore fn return address ret lessthan.doc: ; db ' ( n1 n2 -- flag ) ' ; db 'Puts 0 (false) on the stack if n1 0 ' ; db ' like the x86 loop instruction this is a pre-decrement ' ; db ' so a loop counter of 2 will loop twice. The disadvantage ' ; db ' is that a loop counter of 0 will loop 2^16 times. ' ; dw $-rloop.doc rloop: dw jumpnz.x ; link to prev db 'loop', 4 ; reverse count rloop.x: ; handle loops by modifying virtual ip (in this case SI) pop dx ; juggle return pointer xor ax, ax ; set ax := 0 lodsb ; al := [si]++ get relative loop target into AL ; check return stack for zero, if so continue with next ; instruction (dont jump/loop) mov bx, [es:di-2] ; get top return stack item into bx dec bx ; decrement the loop counter on the return stack cmp bx, 0 ; if bx != 0 continue mov [es:di-2], bx ; update the counter je .exit ; the only difference with jumpz ! cbw ; convert signed byte al to signed word ax (neg offset) sub si, 2 ; realign si to JUMP instruction, add si, ax ; adjust the si code pointer by jump offset .exit: push dx ; restore call return ret load.doc: ; db ' ( sect n -- adr ) ; db ' loads n sectors from disk starting a sect ' ; db ' Return the adr where the sectors were loaded. ' ; dw $-load.doc load: dw rloop.x db 'load', 4 load.x: ; sect n .reset: ; Reset the virtual floppy drive (usb) mov ax, 0 ; mov dl, byte [drive.d];boot drive number (eg for usb 128) int 13h ; jc .reset ; ERROR => reset again .read: ;*** need to save es since rstack points with it!! mov [save.es], es ;*** dictionary is currently about 4K, so load ; sectors after that mov ax, 1000h ; mov es, ax ; es:bx determines where data loaded to ;*** or ax=1100h bx=0 is 4K after 64K segment mov bx, 4096 ; ES:BX = 1000:4096 pop dx ; juggle fn return pop ax ; n==number of sectors push dx ; restore fn return mov ah, 2 ; Load disk data to ES:BX ;mov al, 2 ; Load 2 sectors 512 bytes * 2 == 1K ; try mov cx, 0x0002 ; cylinder 0, sector 2 pop dx ; juggle fn return pop cx ; sect==start sector push dx ; restore fn return ;*** 10 is first sector after 4K dictionary mov ch, 0 ; Cylinder=0 ;mov cl, 10 ; Sector=10 (sector 1 = boot sector) mov dh, 0 ; Head=0 mov dl, byte [drive.d] ; int 13h ; Read! jc .read ; ERROR => Try again ;*** restore es since rstack points with it!! mov es, [save.es] pop dx ; juggle fn return push 4096 ; return address where loaded push dx ; restore fn return ret ;*** load alters es (used for rstack) ;*** need to save save.es: dw 0 save.doc: ; db ' ( -- ) ... ' ; db ' save sectors to disk ' ; dw $-save.doc save: dw load.x db 'save', 4 save.x: ; to do ret ; This opcode and vid.x are obviously not going to be ; available on all hardware. So we need to think about ; how to configure plugable opcodes. Eg: what if a device ; has a gyroscope. We want opcodes to read from that gyroscope ; fg.doc: ; db ' ( n -- ) ' ; db ' set foreground colour for emit' ; dw $-fg.doc fg: dw save.x db 'fg', 2 fg.x: pop dx ; juggle fn return address pop bx ; get foreground colour push dx ; restore fn return address mov [fg.d], bl ; ret fg.d db 5 ; colour cyan vid.doc: ; db ' ( n -- ) ' ; db ' set video mode to n' ; db ' on x86 try 13h mode' ; dw $-vid.doc vid: dw fg.x db 'vid', 3 vid.x: pop dx ; juggle fn return address pop ax ; get video mode push dx ; restore fn return address mov ah, 0 ; ah=0 set video mode function, al=mode int 10h ret noop.doc: ; db 'Does nothing. For some reason most machines ' ; db 'include this instruction. Also it is a good ' ; db 'end marker for the opcodes ' ; dw $-noop.doc noop: dw vid.x db 'nop', 3 noop.x: ret ; ******************************* ; end of byte codes ; ******************************* ; ************ ; some immediate words ; ************ hello.doc: ; db ' ( -- ) ; db ' Just testing immediate procs ' hello: dw noop.x db 'hello', IMMEDIATE | 5 hello.p: db LIT, '!', EMIT db LIT, 'h', EMIT db LIT, 'i', EMIT db EXIT ; things to do in colon: ; Set here to next code space ; create a header. first link back using last.p ; and set last to new word ; then compile name, eg word, or wordcompile then ; compile count, then compile words until ; ; when ; compile "exit" set >code to here ; ; colon will always be called by inputcompile (input,) or ; the "source" word which is just the same as input, ; so colon can just create the word header and then set the ; compile point to the dictionary (as opposed to the "anon" buffer) ; colon.doc: ; db ' ( -- ) ; db ' The most important word. Creates a new ' ; db ' word in the dictionary.' colon: dw hello.p db ':', IMMEDIATE | 1 colon.p: db FCALL dw tocode.p ; pointer to dict compile address db FETCH ; adr ;*** set here var to current compile point db FCALL dw ishere.p ; ; before any new words have been compiled with colon : ; then "last" points to "last" ! After new words have been ; added then "last" will point to the last word added db FCALL dw last.p ; /get pointer to last word in dictionary ;*** insert link to last word at "here" db FCALL dw wcomp.p db FCALL dw toin.p ; a n db DUP ; a n n ;*** no more text, so name is missing db JUMPZ, .noname-$ ; a n ;*** get the name of the new word db FCALL dw parse.p ; a+x n ;*** if parse returns 0 then no name, only whitespace db DUP ; a+x n n db JUMPZ, .noname-$ ; a+x n db TWODUP ; a+x n a+x n ;*** update >word parse position of input buffer db FCALL dw atin.p ; A n db TWODUP ; A n A n ;*** !! use scompile.p or s, here instead ; but it is hanging ;db FCALL ;dw scompile.p ; A n ;db SWAP, DROP ; n db FCALL dw here.p ; A n A n adr /current compile position ;*** copy word name to current compile position db FCALL dw copy.p ; A n db SWAP, DROP, DUP ; n n ;*** update compile pointer (here) db FCALL dw here.p ; n n adr db PLUS ; n adr+n db FCALL dw ishere.p ; n ;*** compile count|control byte after name db FCALL dw ccomp.p ; ;*** set last pointer to new word execution address db FCALL dw here.p ; adr /xt for new word db FCALL dw setlast.p ; adr last /pointer to last word ;db STORE ; ; compile input buffer after word header (here var) db FCALL dw inputcompile.p ;*** set new code compile point db FCALL dw codetohere.p ; db EXIT .noname: db DROP, DROP ; clear data stack db LIT, '?', EMIT ; db LIT, '?', EMIT ; db EXIT semicolon.doc: ; db ' ( -- ) semicolon: dw colon.p db ';', IMMEDIATE | 1 semicolon.p: ; compile an exit ; set >code to here ; set ishere to anon buffer ; doing roff roff to get back to calling function, but ; this is probably not necessary. db LIT, EXIT db LIT, 2 ; compile opcode exit db FCALL dw compile.p db ROFF, ROFF ; a hack a hack !!! db EXIT begin.doc: ; db ' ( -- ) ; db ' marks a jump back address for until/again etc' ; db ' the jump address is left on the data stack ' ; db ' forth- : begin here ; immediate ' begin: dw semicolon.p db 'begin', IMMEDIATE | 5 begin.p: db FCALL dw here.p ; ad /current compilation adr db EXIT again.doc: ; db ' ( -- R: back-adr ) ; db ' jumps back to begin' again: dw begin.p db 'again', IMMEDIATE | 5 again.p: db LIT, JUMP db LIT, 2 ; op 2 db FCALL dw compile.p ; compile to current position (here) db FCALL dw here.p ; jb here db DECR ; jb here-1 /align to jump db MINUS ; jb-here-1 db FCALL dw ccomp.p ; compile to current position (here) db EXIT until.doc: ; db ' ( n -- ) ; db ' at run-time: jumps back to begin if n is true' ; db ' at compile-time: get begin address from data ' ; db ' stack and compiles a conditional relative jump ' ; db ' back to begin. ' until: dw again.p db 'until', IMMEDIATE | 5 until.p: db LIT, JUMPF db LIT, 2 ; jb op 2 db FCALL dw compile.p ; compile to current position (here) db FCALL dw here.p ; jb here db DECR ; jb here-1 /align to jump db MINUS ; jb-here-1 db FCALL dw ccomp.p ; compile to current position (here) db EXIT if.doc: ; db ' run-time: ( n -- ) ' ; db ' compile-time: ( -- adr ) ' ; db ' if the value n on the stack is zero ' ; db ' skip statements after this until next "fi" ' ; db ' compiles a jumpzero and puts the current ' ; db ' address on the data stack. The "fi" command consumes ' ; db ' that address ' if: dw until.p db 'if', IMMEDIATE | 2 if.p: db LIT, JUMPF ; op db LIT, 2 ; op 2 db FCALL dw compile.p ; compile to current position (here) db FCALL dw here.p ; ad /current compilation adr db LIT, 2 ; compile literal number (2) db FCALL dw ccomp.p ; db EXIT else.doc: ; db ' compile.time: ( ad -- jad ) ; db ' at compile time, get the "if" jump address ' ; db ' from the data stack and completes the if jump ' ; db ' using offset from here. Then it leaves the ' ; db ' else jump address on stack for "fi" to deal with ' else: dw if.p db 'else', IMMEDIATE | 4 else.p: ; ja db LIT, JUMP ; ja op db LIT, 2 ; ja op 2 db FCALL dw compile.p ; compile to current position (here) db FCALL dw here.p ; ja ad /current compilation adr db LIT, 2 ; compile literal number (2) db FCALL dw ccomp.p ; db SWAP ; ad ja db DUP ; ad ja ja db FCALL dw here.p ; ad ja ja target db SWAP ; ad ja target ja db MINUS ; ad ja t-ja db INCR ; .... adjust jump target db SWAP ; ad n ja db CSTORE ; ad db EXIT ; better to use the data stack for compile time ; behaviors fi.doc: ; db ' run-time: ( -- ) ; db ' compile-time: ( ad -- ) ' ; db ' at compile time obtains the correct jump ' ; db ' address from the data stack and compiles the correct ' ; db ' target address into a previously compile "if" clause. ' ; db ' This word is called "then" in traditional forths. ' fi: dw else.p db 'fi', IMMEDIATE | 2 fi.p: ;*** we use the data stack for compile time calculations ; "ja" means jump address db DUP ; ja ja db FCALL dw here.p ; ja ja target db SWAP ; ja target ja db MINUS ; ja t-ja db INCR ; .... adjust jump target db SWAP ; a1 a2 n ja db CSTORE ; a1 a2 db EXIT ; ******* ntimes.doc: ; db ' ( n -- ) ; db ' print a star n times. ' ntimes: dw fi.p db 'ntimes', 6 ntimes.p: db LIT, '*', EMIT, DECR, DUP, JUMPNZ, -5 db FCALL dw nl.p db FCALL dw nl.p db EXIT dotstack.doc: ; db ' ( -- ) ; db ' display the items on the data stack without ' ; db ' altering it. The top (or most recent) item ' ; db ' is printed rightmost ' dotstack: dw fi.p db '.s', 2 dotstack.p: ; below we need a copy of the stack depth ; because it gets decremented by the rloop ; need to sieve stack items onto rstack ; with >r, swap, r>, swap, >r etc db DEPTH, DUP ; n n db JUMPNZ, 4 ; n db DROP db EXIT ;*** put all items on return stack db DUP ; n n db RON ; n r: n db SWAP, ROFF ; n a n-x db SWAP, RON ; n n-x r: a db RON ; n r: a n-x db RLOOP, -5 ; n r: a n-x-1 db ROFF ; n 0 r: a b c ... db DROP ; n r: a b c ... ;*** print all stack items db RON ; r: a b c ... n db ROFF ; n r: a b c ... db ROFF ; n c r: a b db DUP ; n c c r: a b db FCALL dw udot.p ; n c r: a b db LIT, ' ', EMIT ; n c r: a b db SWAP, RON ; c r: a b n db RLOOP, -11 ; c r: a b n-1 db ROFF ; a b c ... 0 db DROP ; a b c ... db EXIT dotrstack.doc: ; db ' ( -- ) ; db ' display the top 2 items on the return stack ' dotrstack: dw dotstack.p db '.r2', 3 dotrstack.p: db LIT, ' ', EMIT db ROFF, ROFF ; n m db DUP ; n m m db FCALL dw udot.p ; n m db LIT, ' ', EMIT db RON ; n db DUP ; n n db FCALL dw udot.p ; n db RON db EXIT rcount.doc: ; db ' ( adr -- adr-n n ) ' ; db ' count a reverse counted string, ignoring control bit(s). ' ; db ' Given a pointer to the count byte of a ' ; db ' reverse counted string, return the address of the 1st byte ' ; db ' of the string and its length. This proceedure ' ; db ' may also handle the anding out of the immediate ' ; db ' control bit which is stored in the msb of the ' ; db ' count for execution tokens ' ; dw $-rcount.doc rcount: dw dotrstack.p db 'rcount', 6 rcount.p: ; adr db DUP, CFETCH ; a n / get the count db LIT, 0b00011111 ; a n mask db LOGAND ; a n&mask db DUP ; a n n db RON, MINUS ; adr-n db ROFF ; adr-n n db EXIT dotxt.doc: ; db ' ( adr - ) ' ; db ' given a valid execution token on the stack ' ; db ' the name of the procedure' ; db ' The definition might be ; db ' : .xt -1 rcount type ; ' ; dw $-dotxt.doc dotxt: dw rcount.p db '.xt', 3 dotxt.p: ; xt db DECR ; adr-1 db FCALL dw rcount.p db FCALL dw type.p db EXIT nextxt.doc: ; db ' ( xt -- XT ) ' ; db ' get next execution address in the dictionary ' nextxt: dw dotxt.p db 'xt+', 3 nextxt.p: ; xt db DECR ; xt-1 /points to count|control byte db FCALL dw rcount.p ; adr n /start of name db DROP ; adr db DECR, DECR ; adr-2 db FETCH ; XT / get word pointer db EXIT opcode.doc: ; db ' ( adr -- n ) ' ; db ' Given the address of an execution token ' ; db ' or procedure on the stack provides the numeric ' ; db ' opcode for that procedure or else 0 (-1?) for ' ; db ' an address which does not correspond to a bytecode.' ; db ' This is used to compile text to bytecode ' ; db ' if not an opcode, then compile FCALL etc ' opcode: dw nextxt.p db 'opcode', 6 opcode.p: ; adr db DUP ; adr adr db LITW ; dw op.table ; a a T db FETCHPLUS ; a a T+2 [T] db SWAP, RON ; a a [T] r: T+2 db EQUALS ; a flag r: T+2 db JUMPT, 19 ; a r: T+2 db DUP, ROFF ; a a T+2 ;**** check if end of table db DUP ; a a T+2 T+2 db FETCH ; a a T+2 [T+2] db LIT, -1 ; a a T+2 [T+2] -1 db EQUALS ; a a T+2 flag db JUMPF, .moreops-$ ; a a T+2 db DROP, DROP, DROP ; db LIT, 0 ; 0 db EXIT ; .moreops: db JUMP, -21 ; a a T+2 ;** opcode found, calculate offset db DROP, ROFF ; T+2 db DECR, DECR ; T db LITW dw op.table db MINUS ; T - optable db DIVTWO ; opcode db EXIT dotcode.doc: ; db ' ( opcode - ) ' ; db ' given a valid opcode on the stack, print ' ; db ' the textual version of the opcode. ' ; dw $-dotcode.doc dotcode: dw opcode.p db '.code', 5 dotcode.p: ; op ;*** check for invalid code, nop always last db DUP ; op op db LIT, NOOP, INCR ; op op nop+1 db ULESSTHAN ; op flag db JUMPT, 12 ; op ;*** invalid code db FCALL dw udot.p db LIT, '?', EMIT db LIT, '?', EMIT db EXIT ;*** valid opcode db DUP, PLUS ; op*2 db LITW dw op.table ; op*2 op.table db PLUS ; op*2+op.table db FETCH ; [op*2+op.table] / get execution adr db DECR ; a-1 db FCALL dw rcount.p ; adr n ;*** does the same as rcount ;db DUP, CFETCH ; adr n / get the count ;db DUP ; adr n n ;db RON, MINUS ; adr-n ;db ROFF ; adr-n n db FCALL dw type.p db EXIT listcodes.doc: ; db ' ( - ) ' ; db ' list all valid opcodes for the bytecode machine' ; dw $-listcodes.doc listcodes: dw dotcode.p db 'listcodes', 9 listcodes.p: db LIT, NOOP, RON ; set up loop counter db ROFF, DUP, RON ; n r: n db DUP ; n n r: n db FCALL dw udot.p ; n r: n db LIT, ':', EMIT ; n r: n db FCALL dw dotcode.p ; r: n db LIT, ' ', EMIT ; r: n db RLOOP, -16 ; r: n-1 db ROFF, DROP ; clear counter from rstack db EXIT name.doc: ; db ' ( xt - ) ' ; db ' given a valid execution token for a bytecode or' ; db ' procedure on the stack print the name ' ; dw $-name.doc name: dw listcodes.p db 'name', 4 name.p: ; adr db DECR ; adr-1 /point to count byte ;*** pointer to name and length ; rcount also "ands" out the immediate bit in ; the name count. db FCALL dw rcount.p ; a n db FCALL dw type.p db LIT, ' ', EMIT db EXIT asci.doc: ; db 'shows the asci chars' ; dw $-asci.doc asci: dw name.p db 'asci', 4 asci.p: ;*** in descending order ;*** a gotcha is db lit, 253 (253 too big for byte) db LITW dw 255 .again: db DUP ; c c db LIT, 16 ; c c 16 db DIVMOD ; c rem quot db DROP ; c rem db JUMPNZ, .next-$ ; c db LIT, 13, EMIT db LIT, 10, EMIT db DUP ; c c db FCALL dw udot.p ; c db LIT, ':', EMIT db LIT, ' ', EMIT .next: db DECR, DUP, EMIT ; c db DUP ; c c db JUMPNZ, .again-$ ; c db DROP db EXIT ; in ascending order db LIT, 1, INCR, DUP ; n n db EMIT ; n db DUP db LIT, 252, MINUS, JUMPNZ, -7, EXIT keycode.doc: ; db 'shows the asci chars values when a key is pressed' ; dw $-keycode.doc keycode: dw asci.p db 'keycode', 7 keycode.p: db LIT, 20 db FCALL dw ntimes.p db KEY, DUP ; c c db FCALL dw udot.p ; c db LIT, ' ', EMIT db DUP, EMIT ; c db LIT, 13, EMIT db LIT, 10, EMIT db LIT, 'q', EQUALS db JUMPF, -19 db EXIT nl.doc: ; db 'send a newline to the terminal. ' ; dw $-nl.doc nl: dw keycode.p db 'nl', 2 nl.p: db LIT, 10, EMIT, LIT, 13, EMIT, EXIT udot.doc: ; db ' ( n -- ) ' ; db ' display top stack element as unsigned ' ; db ' number in the current base. ' ; dw $-udot.doc udot: dw nl.p db 'u.', 2 udot.p: db LIT, 0, RON ; n r: 0 db LITW dw base.d ; n adr r: 0 db CFETCH ; n base db DIVMOD ; rem quotient db ROFF, INCR, RON ; rem quotient r: 0+1 db DUP, JUMPNZ, -9 ; rem rem rem ... 0 db DROP ; rem rem ... r: x db LITW ; use digit lookup table dw digits.d ; r r r ... adr r: x db PLUS ; r r ... adr+r r: x db CFETCH ; r r ... d r: x db EMIT ; rem ... print asci digit db RLOOP, -6 ; rem ... r: x-1 db ROFF, DROP ; clear rstack db EXIT ddot.doc: ; db ' ( n -- ) ' ; db ' display top stack element as unsigned ' ; db ' number in decimal ' ; dw $-ddot.doc ddot: dw udot.p db 'd.', 2 ddot.p: ; n db LIT, 0, RON ; n r: 0 db LIT, 10 ; n 10 r: 0 db DIVMOD ; rem quotient db ROFF, INCR, RON ; rem quotient r: 0+1 db DUP, JUMPNZ, -7 ; rem rem rem ... 0 r: x db DROP ; rem rem ... r: x db LIT, '0', PLUS, EMIT ; rem ... print remainder db RLOOP, -4 ; rem ... r: x-1 db ROFF, DROP ; clear rstack db EXIT dothex.doc: ; db ' ( n -- ) ' ; db ' display top stack element as an unsigned ' ; db ' number in hexadecimal ' ; dw $-dothex.doc dothex: dw ddot.p db '.hex', 4 dothex.p: ; n db LITW dw base.d ; n adr db CFETCH ; n base db SWAP ; base n /save original base db LIT, 16 ; base n 16 db LITW dw base.d ; base n 16 adr db CSTORE ; base n /set new base to 16 db FCALL dw udot.p ; base /print number db LITW dw base.d ; base adr db CSTORE ; /restore original base db EXIT dot.doc: ; db ' ( n -- ) ' ; db ' display top stack element as a signed number ' ; db ' in the current base (if u. does so) ' ; dw $-dot.doc dot: dw dothex.p db '.', 1 dot.p: ; n db DUP ; n n db LIT, 0 ; n n 0 db LESSTHAN ; n flag / n<0 ? db JUMPF, 6 ; n db NEGATE ; -n db LIT, '-', EMIT ; -n /print negative sign db FCALL dw udot.p db EXIT cdot.doc: ; db ' ( n -- ) ' ; db ' display top stack element as a signed 8 bit ' ; db ' number in the current base (if u. does so) ' ; db ' This is useful for displaying relative jumps ' ; db ' which are 1 byte signed numbers. ' ; db ' eg: 255 = -1, 254 = -2, 128 = -127 ; dw $-cdot.doc cdot: dw dot.p db 'c.', 2 cdot.p: ; n db DUP ; n n db LITW dw 128 ; n n 128 db LESSTHAN ; n flag / n < 128 db JUMPT, 6 ; n db LITW dw 256 db MINUS ; n-256 db FCALL dw dot.p db EXIT todigit.doc: ; db ' ( c -- n flag ) ' ; db ' converts the ascii character of a digit ' ; db ' on the stack to its corresponding integer ' ; db ' using the base (1digit', 6 todigit.p: ; c db DUP ; c c db LITW dw digits.d ; c c adr db LITW dw base.d ; c c adr adr db CFETCH ; c c a n db RON ; c c a r: n db CFETCHPLUS ; c c a+1 C r: n db SWAP, RON ; c c C r: n a+1 db EQUALS ; c flag r: n a+1 db JUMPT, 10 ; c r: n a+1 db DUP ; c c r: n a+1 db ROFF ; c c a+1 r: n db RLOOP, -8 ; c c a+1 r: n-1 ;*** not a valid digit db DROP, DROP ; c r: 0 db ROFF ; c 0 db EXIT ;*** valid asci digit, convert to number db DROP ; r: n-x a+1 db ROFF, DROP ; r: n-x db ROFF ; n-x db LITW dw base.d ; n-x adr db CFETCH ; n-x n db SWAP ; n n-x db MINUS ; x db LIT, -1 ; x -1 / -1 is true flag db EXIT digits.d: db '0123456789abcdefghijklmnopqrstuvwxyz' base.doc: ; db ' ( -- adr ) ' ; db ' puts on the stack the address of the current ' ; db ' numeric base ' ; db ' which is used for displaying and parsing ' ; db ' numbers. The base should be 1 < base < 37 ' ; db ' since these are the digits which can be ' ; db ' displayed using numerals and letters ' ; db ' eg: base c@ . ' ; db ' displays the current base ' ; dw $-base.doc base: dw todigit.p db 'base', 4 base.p: db LITW dw base.d db EXIT base.d: db 10 bin.doc: ; db ' ( -- ) ' ; db ' sets the numeric base to binary ' ; dw $-bin.doc bin: dw base.p db 'bin', 3 bin.p: db LIT, 2 db LITW dw base.d db CSTORE db EXIT hex.doc: ; db ' ( -- ) ' ; db ' sets the numeric base to hexadecimal ' ; dw $-hex.doc hex: dw bin.p db 'hex', 3 hex.p: db LIT, 16 db LITW dw base.d db CSTORE db EXIT deci.doc: ; db ' ( -- ) ' ; db ' sets the numeric base to 10 ' ; dw $-deci.doc deci: dw hex.p db 'deci', 4 deci.p: db LIT, 10 db LITW dw base.d db CSTORE db EXIT tonumber.doc: ; db ' ( adr n -- adr/n flag ) ' ; db ' Given a pointer to string adr with length "n" ' ; db ' attempt to convert the string to ' ; db ' a number. If successful put number and true flag' ; db ' on the stack, if not put pointer to incorrect digit' ; dw $-tonumber.doc tonumber: dw deci.p db '>number', 7 tonumber.p: ; a n db LIT, 0, RON ; a n r: 0 /false neg flag db RON ; a r: 0 n ;*** check for +/- at first char db DUP, CFETCH ; a c r: 0 n db LIT, '+' ; a c '+' ... db EQUALS ; a flag ... db JUMPF, 8 ; a ... db ROFF, DECR, RON ; a r: n-1 db INCR ; a+1 r: 0 n-1 db JUMP, 16 ; a+1 r: 0 n-1 db DUP, CFETCH ; a c r: 0 n db LIT, '-' ; a c '-' r: 0 n db EQUALS ; a flag r: 0 n db JUMPF, 9 ; a r: 0 n ;*** set a +/- flag on the rstack db ROFF, DECR ; a n-1 r: 0 db ROFF, DECR ; a n-1 -1 db RON, RON ; a r: -1 n-1 db INCR ; a+1 r: -1 n-1 ;*** exit if zero length string or just +/- db ROFF ; a n r: -1 db DUP ; a n n r: -1 db JUMPNZ, 5 ; a n r: -1 db ROFF, DROP ; a 0 db EXIT db RON ; a r: -1 n db LIT, 0 ; a 0 r: n /initial sum db SWAP ; 0 a r: n db CFETCHPLUS ; 0 a+1 d r: n ;*** check if digit db FCALL dw todigit.p ; 0 a+1 D flag r: n db JUMPF, 24 ; 0 a+1 D r: n ;*** db RON ; 0 a+1 r: n 0-9 db SWAP ; a+1 s r: n digit /s is sum db LITW dw base.d db CFETCH ; a+1 s base r: n digit db UMULT ; a+1 s*base r: n digit db ROFF ; a+1 s*base digit r: n db PLUS ; a+1 s r: -flag n db SWAP ; s a+1 r: -flag n db RLOOP, -16 ; s a+1 r: -flag n-1 /back to c@+ db ROFF, DROP ; s a+1 r: -flag db DROP ; s r: -flag db ROFF ; s -flag db JUMPF, 3 ; s / skip if + db NEGATE ; -s / negate if flag set db LIT, -1 ; s -1 /value and true flag db EXIT ;*** non digit ; sum a+1 d db DROP, SWAP ; a+1 sum r: 0 n db DROP ; a+1 r: 0 n db LIT, 0 ; a+1 0 db ROFF, DROP ; clear return stack db ROFF, DROP ; clear return stack db EXIT test.tonumber.doc: ; db ' Testing >number by accepting input and ' ; db ' displaying the number ' test.tonumber: dw tonumber.p db 'test.>number', 12 test.tonumber.p: db LIT, 10, EMIT db LIT, 13, EMIT db LITW dw term.d db FCALL dw accept.p db LITW dw term.d db COUNT ; a n db DUP ; a n n db JUMPNZ, 3 ; a n /exit if no input db EXIT db FCALL dw tonumber.p db LIT, ' ', EMIT db FCALL dw dot.p db LIT, ' ', EMIT db DUP db FCALL dw udot.p db LIT, ' ', EMIT db FCALL dw dot.p db LIT, 10, EMIT db LIT, 13, EMIT db JUMP, -42 db EXIT toword.doc: ; db ' ( -- adr n ) ' ; db ' put on the stack a pointer to the current ' ; db ' word and its length. ' toword: dw test.tonumber.p db '>word', 5 toword.p: ; handle zero case (no word found) db LITW dw toword.d ; adr db FETCH ; aw db DUP ; aw aw db LITW dw toin.d ; aw aw a db FETCH ; aw aw ap db SWAP ; aw ap aw db MINUS ; aw n db EXIT toword.d dw 0 ; pointer to start of current word parse.doc: db ' ( a1 n -- a2 m ) ' db ' given pointer to string a1 with length n, ' db ' find the start of next word (i.e. non-whitespace char) ' db ' return start position a2 and length m ' db ' eg: >in parse 2dup setin 2dup type find etc ' dw $-parse.doc parse: dw toword.p db 'parse', 5 parse.p: ; adr n db RON ; adr r: n db CFETCHPLUS ; a+1 [a] r: n db LIT, ' ' ; a+1 c space r: n db EQUALS ; a+1 flag ... db JUMPF, 7 ; a+1 ... db RLOOP, -6 ; a+1 r: n-1 ;*** no char found, so return 0 db DECR ; a r: 0 db ROFF ; a 0 db EXIT ; ;*** char found db DECR ; a r: n-m ;*** for debug ; db DUP, CFETCH, EMIT db DUP ; a a ... ;*** check rstack==0 and exit if so ;*** scan for next whitespace db CFETCHPLUS ; a a+1 [a] r: n-m db LIT, ' ' ; a a+1 c space r: n-m db EQUALS ; a a+1 flag ... db JUMPT, 5 ; a a+1 ... db RLOOP, -6 ; a a+1 r: n-m-1 db INCR ; a a+2 ... /balance decr ;*** db DECR ; a a+p-1 r: 0 db ROFF, DROP ; a a+p-1 /clear rstack ;*** now calculate length of word db RON, DUP, ROFF ; a a a+p-1 db SWAP, MINUS ; a p-1 db EXIT inwords.doc: ; db ' ( -- ) ' ; db ' show all the words in the input buffer ' ; db ' this can be used as a model for parsing ' ; db ' and compiling each word ' ; dw $-inwords.doc ; inwords: dw parse.p db 'inwords', 7 inwords.p: db LITW dw pad.d ; a db FCALL dw accept.p db FCALL dw pad.p ; adr db FCALL dw resetin.p ; reset >in >word atin etc db FCALL dw toin.p ; a n db DUP ; a n n db JUMPZ, 23 ; a n db FCALL dw parse.p ; a+x n db TWODUP ; a+x n a+x n db FCALL dw type.p ; a+x n ;*** if parse returns 0 then no more words (all space) db DUP ; a+x n n db JUMPZ, 13 ; a+x n ;*** update >word etc db FCALL dw atin.p db LIT, 13, LIT, 10 ; newline print db EMIT, EMIT db JUMP, -25 ;*** no more words (>in returned zero) db DROP, DROP ; clear stack db EXIT findwords.doc: ; db ' ( -- ) ' ; db ' parse and find each word' ; dw $-findwords.doc findwords: dw inwords.p db 'findwords', 9 findwords.p: db LITW dw pad.d ; a db FCALL dw accept.p db FCALL dw pad.p ; adr db FCALL dw resetin.p ; reset >in >word atin etc db FCALL dw toin.p ; a n db DUP ; a n n db JUMPZ, 30 ; a n db FCALL dw parse.p ; a+x n ;*** if parse returns 0 then no more words (all space) db DUP ; a+x n n db JUMPZ, 24 ; a+x n ;*** update >word etc db TWODUP ; a+x n a+x n db FCALL dw type.p ; a+x n ; db TWODUP ; a+x n a+x n db FCALL dw find.p ; a+x n xt db FCALL dw udot.p ; a+x n ; db FCALL dw atin.p db LIT, 13, LIT, 10 ; newline print db EMIT, EMIT db JUMP, -32 ;*** no more words (>in returned zero) db DROP, DROP ; clear stack db EXIT seecomp.doc: ; db ' ( -- ) ' ; db ' compiles one line of text to anon and ' ; db ' displays the decompilation. This is for testing' ; db ' the compilation process. Enter exits the loop' ; dw $-seecomp.doc seecomp: dw findwords.p db 'see,', 4 seecomp.p: .again: db LITW dw anon.d db FCALL dw ishere.p db LITW dw pad.d ; a : the address of pad buffer db DUP ; a a db FCALL dw accept.p ; a ;*** exit if no input, i.e 'pad' count == 0 db DUP ; a a db CFETCH ; a count : count of 'pad' db JUMPNZ, 4 ; a db DROP db EXIT db FCALL dw resetin.p ; reset >in >word atin etc .nextword: db FCALL dw toin.p ; a n db DUP ; a n n ;*** if no more characters, exit loop db JUMPZ, .end-$ ; a n db FCALL dw parse.p ; a+x n ;*** if parse returns 0 then no more words (all space) db DUP ; a+x n n db JUMPZ, .end-$ ; a+x n db TWODUP ; a+x n a+x n ;*** update >word etc db FCALL dw atin.p ; a+x n db FCALL dw tick.p ; n/op/xt flag ;*** if flag==0 abort, unknown word/number db DUP ; n/op/xt flag flag db JUMPZ, .error-$ ; n/op/xt flag db FCALL ; n/op/xt dw compile.p ; ... (if/fi may leave data here) db JUMP, .nextword-$ .end: ;*** no more words (>in returned zero) db DROP, DROP ; clear stack db LIT, EXIT db LIT, 2 ; compile opcode exit db FCALL dw compile.p ;*** show the decompilation db LIT, 'S', EMIT db LIT, ':', EMIT db FCALL dw dotstack.p db LIT, ' ', EMIT db LIT, 'R', EMIT db LIT, ':', EMIT db FCALL dw dotrstack.p db LITW dw anon.d db LIT, 25 ; ad n db FCALL dw decomp.p ; ad2 db DROP db LIT, 13, EMIT db LIT, 10, EMIT ;*** loop forever db LJUMP dw .again-$ .error: ;db FCALL ;dw dotstack.p db LIT, 13, EMIT db LIT, 10, EMIT db DROP, DROP ; a+x n db FCALL dw toword.p ; a+x n db FCALL dw type.p db LIT, ' ', EMIT db LIT, '?', EMIT db LIT, '?', EMIT db LIT, 13, EMIT db LIT, 10, EMIT db LJUMP dw .again-$ db EXIT inputcompile.doc: ; db ' ( -- ) ' ; db ' compiles the input buffer starting from the current ' ; db ' input position until the end of the buffer ' ; dw $-inputcompile.doc inputcompile: dw seecomp.p db 'input,', 6 inputcompile.p: .nextword: db FCALL dw toin.p ; a n db DUP ; a n n db JUMPZ, .end-$ ; a n db FCALL dw parse.p ; a+x n ;*** if parse returns 0 then no more words (all space) db DUP ; a+x n n db JUMPZ, .end-$ ; a+x n db TWODUP ; a+x n a+x n ;*** update >word db FCALL dw atin.p ; a+x n ;*** convert name to number/opcode/fpointer + flag db FCALL dw tick.p ; n/op/xt flag ;db FCALL ;dw dotstack.p ;*** if flag==0 abort, unknown word/number db DUP ; m flag flag db JUMPZ, .error-$ ; n/op/xt flag ;*** immediate words like if/fi begin will leave ; parameters on the data stack db FCALL dw compile.p ; db JUMP, .nextword-$ .end: ;*** no more words (>in returned zero) ;*** compile a final exit even if no semi-colon was ; given db DROP, DROP ; clear stack db LIT, EXIT db LIT, 2 ; compile opcode exit db FCALL dw compile.p db EXIT .error: ;db FCALL ;dw dotstack.p ; n/op/xt flag db LIT, 13, EMIT db LIT, 10, EMIT db DROP, DROP ; db FCALL dw toword.p ; ad n db LIT, 5, FG ; set word colour to cyan db FCALL dw type.p db LIT, 4, FG ; set word colour to red db LIT, ' ', EMIT db LIT, '?', EMIT db LIT, '?', EMIT db LIT, 7, FG ; set word colour to cyan db LIT, 13, EMIT db LIT, 10, EMIT ;*** compile an exit even when an error occurs ; db LIT, EXIT db LIT, 2 ; compile opcode exit db FCALL dw compile.p db EXIT ; now, should adr be a counted string? should we compile only one ; block (1K), or have another paramter to determine the length? ; this should be (adr length -- ). And source should be just the ; same word as inputcompile.p ; One problem: words outside of : defs are compiled to the anon ; buffer, and then need to be executed. Eg the immediate word ; source.doc: ; db ' ( adr -- ) ' ; db ' compile forth source code from address adr ' ; db ' This is called "load" in many forths.' ; dw $-source.doc source: dw inputcompile.p db 'source', 6 source.p: ;*** set "in" var to adr db FCALL dw resetin.p ; reset >in >word atin etc db LITW dw anon.d db FCALL dw ishere.p ;*** rub out anon db LIT, EXIT db LIT, 2 ; compile opcode exit db FCALL dw compile.p db LITW dw anon.d db FCALL dw ishere.p ;*** compile input buffer db FCALL dw inputcompile.p .run: ;*** now run the compiled stuff db LITW dw anon.d db PCALL db LIT, 13, EMIT db LIT, 10, EMIT db LIT, 2, FG ; set to green db LIT, 'o', EMIT db LIT, 'k', EMIT db LIT, 7, FG ; set to white db LIT, 13, EMIT db LIT, 10, EMIT db EXIT ; I would like to call this "shell". Also this word can be ; compiled from source. interp.doc: ; db ' ( -- ) ' ; db ' parse compile and execute words' ; dw $-interp.doc interp: dw source.p db 'interp', 6 interp.p: ;*** compile to anon db FCALL dw list.p .again: db LITW dw anon.d db FCALL dw ishere.p ;*** rub out anon db LIT, EXIT db LIT, 2 ; compile opcode exit db FCALL dw compile.p db LITW dw anon.d db FCALL dw ishere.p db LITW dw pad.d ; a (address of pad buffer) db DUP ; a a db FCALL ; get some text into input buffer dw accept.p ; a ;*** set "in" var to beginning of "pad" buffer db FCALL dw resetin.p ; reset >in >word atin etc ;*** compile input buffer to anon db FCALL dw inputcompile.p ;db LIT, 0 ; zero terminate for convenience ;db FCALL ;dw ccomp.p .run: ;*** now run the compiled stuff db LITW dw anon.d db PCALL db LIT, 13, EMIT db LIT, 10, EMIT db LIT, 2, FG ; set to green db LIT, 'o', EMIT db LIT, 'k', EMIT db LIT, 7, FG ; set to white db LIT, 13, EMIT db LIT, 10, EMIT ;*** loop forever db LJUMP dw .again-$ db EXIT ; never reaches here find.doc: ; db ' ( adr n -- xt ) ' ; db ' return the execution address for the given word function. ' ; db ' Given a pointer to a string "adr" with length n ' ; db ' return the execution token (address) for the word' ; db ' or else zero if the word was not found. ' ; dw $-find.doc find: dw interp.p db 'find', 4 find.p: ; a n db FCALL ; pointer to last word in dictionary dw last.p ; a+1 n A .again: db DECR ; point to count|control byte of name db FCALL dw rcount.p ; a n A N ;*** ;db DUP ; a+1 n A-1 A-1 ;db CFETCH ; .. A-1 N / get the count ;db DUP ; .. A-1 N N ;db RON, MINUS ; .. adr-N r: N ;db ROFF ; .. adr-N N ; a n A N ;db FCALL ;dw print.p ;*** now compare the 2 string lengths n & N db SWAP ; a n N A db RON, RON ; a n r: A N db DUP, ROFF ; a n n N r: A db EQUALS ; a n flag r: A db JUMPF, .lengthsnotequal-$ ; a n r: A db ROFF ; a n A db SWAP ; a A n ;*** save values on rstack, clumsy db RON, RON, RON; r: n A a db ROFF, DUP ; a a r: n A db ROFF, DUP ; a a A A r: n db ROFF, DUP ; a a A A n n db RON, SWAP, RON ; a a A n r: n A ;*** compare two strings db FCALL ; are strings equal? dw compare.p ; a flag r: n A ; db JUMPF, .notequal-$ ; a r: n A ; if strings same clear stacks db DROP ; r: n A db ROFF, ROFF ; A n db PLUS, INCR ; A+n+1 ; A+n+1 is the execution address. found, so exit now db EXIT ; if false, balance stacks and jump down .notequal: ; a r: n A db ROFF, ROFF ; a A n db SWAP ; a n A db JUMP, 3 ; a n A /get next pointer .lengthsnotequal: db ROFF ; a n A db DECR, DECR ; a n A-2 /A-2 points to previous db FETCH ; a n [A-2] db DUP ; a n [A-2] [A-2] db JUMPNZ, .again-$ ; a n [A-2] db DROP, DROP, DROP ; clear stack db LIT, 0 ; zero means not found db EXIT test.find.doc: ; db ' Testing find by accepting input and ' ; db ' displaying the found execution token ' test.find: dw find.p db 'test.find', 9 test.find.p: db FCALL dw listxt.p db LIT, 10, EMIT db LIT, 13, EMIT db LITW dw term.d db FCALL dw accept.p db LITW dw term.d ; adr db COUNT ; adr+1 n db FCALL dw find.p db LIT, ' ', EMIT db FCALL dw udot.p db LIT, 10, EMIT db LIT, 13, EMIT db JUMP, -25 db EXIT immediate.doc: ; db ' ( xt -- flag ) ' ; db ' returns 0 if word is not immediate. <>0 otherwise ' ; db ' given the execution address for a procedure ' ; db ' return a flag indicating if the procedure ' ; db ' is immediate or not. Immediate procedures are ' ; db ' executed at compile time, not compiled ' ; db ' so, essentially, they compile themselves. ' ; db ' this allows the compiler to be extended by ' ; db ' procedures. The immediate control bit is the ' ; db ' most significant bit of the count byte in the ' ; db ' name. Immediate words have both a compile-time and ' ; db ' a run-time behaviour, whereas non-immediate words ' ; db ' have only a run-time behaviour. immediate: dw test.find.p db 'imm?', 4 immediate.p: ; xt db DECR ; xt-1 db CFETCH ; [xt-1] /get the count byte db LIT, IMMEDIATE ; n 0b10000000 db LOGAND ; n & imm / zero or non zero db EXIT tick.doc: ; db ' ( p n -- n flag) ' ; db ' given a pointer "p" to a string of length n ' ; db ' attempt to convert the name to either ' ; db ' an opcode, procedure execution code, or number/integer ' ; db ' the flag indicates the type of token returned ' ; db ' a flag of zero means that the name is neither ' ; db ' number nor opcode nor xt' ; db ' flag=0 not number nor word ' ; db ' flag=1 if number, 2 if opcode, 3 if procedure ' ; dw $-tick.doc tick: dw immediate.p db 'tick', 4 tick.p: ; a n db TWODUP ; a n a n db FCALL dw find.p ; a n xt/0 db DUP ; a n xt xt db JUMPNZ, .opcode-$ ; a n xt ;*** not found, try to convert to number db DROP ; a n db FCALL dw tonumber.p ; adr/n flag db JUMPNZ, .number-$ ; adr/n ;*** not a number, push false flag and exit db LIT, 0 ; adr 0 db EXIT ;*** is a number .number: ; n db LIT, 1 ; n 1 /flag=1 means number db EXIT .opcode: ;*** check if opcode ; a n xt db SWAP, DROP ; a xt db SWAP, DROP ; xt db DUP ; xt xt db FCALL ; does this address correspond to an opcode dw opcode.p ; xt op|0 db DUP ; xt op|0 op|0 db JUMPZ, .proceedure-$ ; xt op ;*** is an opcode db SWAP, DROP ; op /drop execution token address db LIT, 2 ; op 2 /flag=2 means opcode db EXIT .proceedure: ;*** must be procedure, ; xt 0=op db DROP ; xt db LIT, 3 ; xt 3 /flag=3 means procedure db EXIT test.tick.doc: ; db ' Testing tick by accepting input and ' ; db ' displaying the found execution token ' test.tick: dw tick.p db 'test.tick', 9 test.tick.p: db LIT, 10, EMIT db LIT, 13, EMIT db LITW dw term.d db FCALL dw accept.p db LITW dw term.d ; adr db COUNT ; adr+1 n ;*** exit if no input db DUP db JUMPNZ, 3 db EXIT db FCALL dw tick.p ; 0/n/op/xt flag db LIT, 10, EMIT db LIT, 13, EMIT db FCALL dw dotstack.p db LIT, 10, EMIT db LIT, 13, EMIT db JUMP, -32 db EXIT args.doc: ; db ' ( op -- flag ) ' ; db ' given a valid opcode return flag=1 if the ' ; db ' the opcode requires a one byte ' ; db ' argument or return flag=2 if the opcode requires ' ; db ' a 2byte argument or flag=0 if no arguments required. ' ; dw $-args.doc args: dw test.tick.p db 'args', 4 args.p: ; lit, jump, jumpz, jumpnz, rloop db DUP ; op op db LIT, LIT ; op op op2 db EQUALS ; op flag db JUMPT, .one-$ ; op db DUP ; op op db LIT, JUMP ; op op op2 db EQUALS ; op flag db JUMPT, .one-$ ; op db DUP ; op op db LIT, JUMPZ ; op op op2 db EQUALS ; op flag db JUMPT, .one-$ ; op db DUP ; op op db LIT, JUMPNZ ; op op op2 db EQUALS ; op flag db JUMPT, .one-$ ; op db DUP ; op op db LIT, RLOOP ; op op op2 db EQUALS ; op flag db JUMPT, .one-$ ; op ; litw, fcall, ljump, db DUP ; op op db LIT, LITW ; op op op2 db EQUALS ; op flag db JUMPT, .two-$ ; op db DUP ; op op db LIT, FCALL ; op op op2 db EQUALS ; op flag db JUMPT, .two-$ ; op db DUP ; op op db LIT, LJUMP ; op op op2 db EQUALS ; op flag db JUMPT, .two-$ ; op .zero: db DROP db LIT, 0 ; 0 db EXIT .one: db DROP db LIT, 1 ; 1 db EXIT .two: db DROP db LIT, 2 ; 2 db EXIT ccomp.doc: ; db ' ( n -- ) ' ; db ' compile byte value n at next available byte ' ; b ' as given by here.p ' ; dw $-ccomp.doc ccomp: dw args.p db 'c,', 2 ccomp.p: ;*** compile single byte db FCALL ; /get compile point dw here.p ; n adr db CSTOREPLUS ; a+1 db FCALL dw ishere.p ; /update compile point db EXIT wcomp.doc: ; db ' ( n -- ) ' ; db ' compile 2 byte value at next available space ' ; db ' as given by the "here" variable ' ; db ' code: : w, here !+ ishere ; ' ; dw $-wcomp.doc wcomp: dw ccomp.p db 'w,', 2 wcomp.p: db FCALL ; /get compile point dw here.p ; n adr db STOREPLUS ; a+2 db FCALL dw ishere.p ; /set compile point to new address (a+2) db EXIT scompile.doc: ; db ' ( adr n -- ) ' ; db ' compile the string at adr with length n to the ' ; b ' current compile position as given by here ' ; dw $-wordcompile.doc scompile: dw wcomp.p db 's,', 2 scompile.p: ;*** compile word ; ad n ;*** check for n==0 here db DUP ; ad n n db JUMPNZ, .notzero-$ ; ad n db DROP, DROP ; db EXIT .notzero: ;*** n > 0 db RON ; ad r: n /n is loop counter db CFETCHPLUS ; ad+1 c r: n .nextchar: db FCALL dw ccomp.p ; ad+1 r: n db RLOOP, .nextchar-$ ; ad+1 r: n-1 db EXIT compile.doc: ; db ' ( n flag -- ) ' ; db ' compile value "n" at next availabe position ' ; b ' as given by here.p where flag indicates ' ; db ' the type of value. ' ; db ' 1 literal, 2 opcode, 3 procedure' ; dw $-compile.doc compile: dw scompile.p db ',', 1 compile.p: ;*** 1=literal number ; n flag db DUP ; n flag flag db LIT, 1, EQUALS ; n flag 0/-1 db JUMPZ, 14 ; n flag ;*** compile number db DROP ; n db LIT, LITW ; n op db FCALL ; /get compile point dw here.p ; n op adr db CSTOREPLUS ; n a+1 db STOREPLUS ; a+3 db FCALL dw ishere.p ; /update compile point db EXIT ;*** check if opcode ; n flag db DUP ; n flag flag db LIT, 2, EQUALS ; n flag 0/-1 db JUMPZ, 11 ; n flag ;*** 2 is opcode ;*** compile the bytecode to given address db DROP ; op db FCALL ; /get compile point dw here.p ; op adr db CSTOREPLUS ; adr+1 db FCALL ; /set compile point dw ishere.p ; db EXIT ;*** check if procedure ; n flag db DUP ; n flag flag db LIT, 3, EQUALS ; n flag 0/-1 db JUMPF, .error-$ ; n flag ;*** 3 procedure ; xt flag db DROP ; xt ;*** check if immediate? db DUP ; xt xt db FCALL dw immediate.p ; xt flag db JUMPT, .immediate-$ ; xt db LIT, FCALL ; xt op db FCALL ; /get compile point dw here.p ; xt op adr db CSTOREPLUS ; xt adr+1 db STOREPLUS ; adr+3 db FCALL ; /set compile point dw ishere.p ; db EXIT ;*** immediate proc, execute, dont compile .immediate: db PCALL db EXIT .error: ; n flag db DROP, DROP db EXIT headdot.doc: ; db ' ( xt -- ) ' ; db ' show the dictionary header for a word function. ' ; db ' The word header is shown in a form suitable for ' ; db ' debugging. ' ; dw $-headdot.doc headdot: dw compile.p db 'head.', 5 headdot.p: ; xt db DUP ; xt xt db DECR ; xt xt-1 /points to count|control byte db FCALL dw rcount.p ; xt adr n /start of name db DROP ; xt adr db DECR, DECR ; xt adr-2 ;db FETCH ; XT / get word pointer ;*** print head memory address db LIT, 13, EMIT db LIT, 10, EMIT db DUP ; xt a a db FCALL dw udot.p ; xt a db LIT, ':', EMIT db LIT, ' ', EMIT ;*** print the link address to next word in dictionary db LIT, '[', EMIT db FETCH ; xt [a] db DUP ; xt [a] [a] db FCALL dw udot.p ; xt [a] db LIT, ']', EMIT db LIT, ' ', EMIT db LIT, '-', EMIT db LIT, '>', EMIT db LIT, ' ', EMIT ;*** print the name of the linked word db DECR ; xt A-1 /point to count|control byte db FCALL dw rcount.p ; xt A-n n db FCALL dw type.p ; xt db LIT, 13, EMIT ; db LIT, 10, EMIT ; db DECR ; xt-1 /point to count|control byte db FCALL dw rcount.p ; a-n n db RON, DUP ; a-n a-n R: n db FCALL dw udot.p ; a-n R: n db LIT, ':', EMIT db LIT, ' ', EMIT db ROFF ; a-n n db DUP, RON ; a-n n R: n ;*** print word name in quotes db LIT, '"', EMIT db FCALL dw type.p ; R: n db LIT, '"', EMIT db ROFF ; n db LIT, ' ', EMIT ;*** print word length|control in quotes ;!! need to handle immediate words which have msb set db FCALL dw udot.p ; db LIT, 13, EMIT ; db LIT, 10, EMIT ; db EXIT worddump.doc: ; db ' ( xt -- ) ' ; db ' shows how a word is compiled in the dictionary ' ; db ' The dictionary header and compiled code is displayed ' ; db ' for the word corresponding to the execution address. ' ; dw $-worddump.doc worddump: dw headdot.p db 'word..', 6 worddump.p: db DUP ; xt xt db FCALL dw headdot.p ; xt db LIT, 20 ; xt n /decompile up to n bytes db FCALL dw decomp.p db EXIT ; : word.. dup head. 20 decomp ; decomp.doc: ; db ' ( adr n -- a2 ) ' ; db '' ; db ' decompiles n bytes starting at address n ' ; db ' returns the next address after the decompiled ' ; db ' bytes. Need to handle jumps too. This cannot decompile' ; db ' machine code, only bytecodes ' ; dw $-decomp.doc decomp: dw worddump.p db 'decomp', 6 decomp.p: ; adr n db RON ; adr r: n .again: db LIT, 13, EMIT db LIT, 10, EMIT db DUP ; a a db FCALL dw udot.p ; a db LIT, ':', EMIT db LIT, ' ', EMIT db CFETCHPLUS ; a+1 c r: n db DUP ; a+1 c c db JUMPZ, .invalid-$ ; a+1 c db DUP, LIT, NOOP, INCR ; a+1 c c op+1 r: n db ULESSTHAN ; a+1 c flag r: n db JUMPT, .valid-$ ; a+1 c r: n ;*** invalid opcode .invalid: ; a+x c db FCALL dw udot.p db LIT, '?', EMIT ;*** clear rstack db ROFF, DROP db EXIT .valid: ;*** valid opcode db DUP ; a+1 c c r: n db FCALL dw dotcode.p ; a+1 c r: n db LIT, ' ', EMIT ;*** is fcall db DUP ; a+1 c c r: n db LIT, FCALL ; a+1 c c op r: n db EQUALS ; a+1 c flag ... db JUMPF, 21 ; a+1 c ... ;*** fcall, get xt db DROP ; a+1 ... db FETCHPLUS ; a+3 xt ... db LIT, '<', EMIT db FCALL dw dotxt.p ; a+3 r: n db LIT, '>', EMIT db LIT, ' ', EMIT db RLOOP, .again-$ ; a+3 r: n-1 db ROFF, DROP ; clear rstack db EXIT ;*** check if 1 or 2 byte argument or non db DUP ; a+1 c c r: n db FCALL dw args.p ; a+1 c args r: n db DUP ; a+1 c args args r: n db JUMPZ, .zerobytes-$ ; a+1 c args ... db LIT, 1, EQUALS ; a+1 c flag db JUMPT, .onebyte-$ ; a+1 c ;*** opcode takes 2 byte argument .twobytes: db DROP ; a+1 ... db FETCHPLUS ; a+3 xt ... db LIT, '<', EMIT db FCALL dw dot.p ; a+3 r: n db LIT, '>', EMIT db LIT, ' ', EMIT db RLOOP, .again-$ ; a+3 r: n-1 db ROFF, DROP ; clear rstack db EXIT ;*** opcode takes 1 byte argument .onebyte: db DROP ; a+1 ... db CFETCHPLUS ; a+2 n ... db LIT, '<', EMIT ;*** cdot prints 8 bit number as signed db FCALL dw cdot.p ; a+2 r: n db LIT, '>', EMIT db LIT, ' ', EMIT db RLOOP, .again-$ ; a+2 r: n-1 db ROFF, DROP ; clear rstack db EXIT ;*** opcode takes no argument .zerobytes: ; a+1 c args ... db DROP, DROP db RLOOP, .again-$ ; a+1 r: n-1 db ROFF, DROP ; clear rstack db EXIT tocode.doc: ; db ' ( -- adr ) ' ; db ' puts on the stack the next available byte' ; db ' in the dictionary or just the variable ?? ' ; dw $-tocode.doc tocode: dw decomp.p db '>code', 5 tocode.p: db LITW dw tocode.d ; db FETCH / maybe not db EXIT tocode.d: dw dictionary codetohere.doc: ; db ' ( -- ) ' ; db ' sets the dict compile point to the here var' ; dw $-codetohere.doc codetohere: dw tocode.p db 'code>here', 9 codetohere.p: db FCALL dw here.p ; a db LITW dw tocode.d ; a A db STORE ; db EXIT here.doc: ; db ' ( -- adr ) ' ; db ' puts on the stack the current compile position' ; db ' in the code data space ' ; dw $-here.doc here: dw codetohere.p db 'here', 4 here.p: db LITW dw here.d db FETCH db EXIT here.d: dw 0 ; pointer to next byte ; could call this "there" !! ishere.doc: ;db ' ( adr -- ) ' ;db ' set position of next available byte' ;db ' for compilation ("here" variable) to address adr' ;dw $-ishere.doc ishere: dw here.p db 'ishere', 6 ishere.p: ; adr db LITW dw here.d ; adr b db STORE ; db EXIT search.doc: ; db ' ( a-start ad n -- ad2) ' ; db ' search for a string in memory ' ; dw $-search.doc search: dw ishere.p db '/', 1 search.p: ; a A n db EXIT ; "a" is top of stack. ie rightmost is last-on first-off copy.doc: ; db ' ( A n a -- ) ' ; db ' copy n bytes from address A to address a ' ; db ' this cannot deal with overlapping memory areas. ' ; dw $-copy.doc copy: dw search.p db 'copy', 4 copy.p: ; A n a db SWAP ; A a n db RON ; A a r: n /n loop counter db SWAP ; a A .again: db CFETCHPLUS ; a A+1 [A] ; db DUP, EMIT ; debug db SWAP ; a [A] A+1 db RON ; a [A] r: n A+1 db SWAP ; [A] a r: n A+1 db CSTOREPLUS ; a+1 r: n A+1 db ROFF ; a+1 A+1 r: n db RLOOP, .again-$ ; a+1 A+1 r: n-1 db ROFF ; a+n A+n 0 db DROP, DROP, DROP ; db EXIT compare.doc: ; db ' ( a A n -- flag) ' ; db ' given 2 pointers to strings a and A ' ; db ' compare the 2 strings for n bytes ' ; db ' and put -1 on stack as flag if the strings are ' ; db ' the same or flag=0 on stack if the strings ' ; db ' are different. ' ; dw $-compare.doc compare: dw copy.p db 'compare', 7 compare.p: ; a A n db RON ; a A r: n /n loop counter db CFETCHPLUS ; a A+1 [A] ; db DUP, EMIT ; debug db SWAP ; a [A] A+1 db RON, RON ; a r: n A+1 [A] db CFETCHPLUS ; a+1 [a] r: n A+1 [A] ; db DUP, EMIT ; debug db ROFF ; a+1 [a] [A] r: n A+1 db EQUALS ; a+1 flag r: n A+1 db JUMPT, 10 ; a+1 r: n A+1 db ROFF, ROFF ; a+1 A+1 n db DROP, DROP, DROP ; clear stacks db LIT, 0 ; flag=0 (false) db EXIT db ROFF ; a+1 A+1 r: n db RLOOP, -18 ; a+1 A+1 r: n-1 db ROFF ; a+n A+n 0 db DROP, DROP, DROP ; clear stacks db LIT, -1 db EXIT list.doc: ; db ' ( -- ) ' ; db ' list all words in the dictionary by name ' ; dw $-list.doc list: dw compare.p db 'list', 4 list.p: db FCALL dw last.p ; a .again: db DECR ; a-1 / count|control byte db FCALL dw rcount.p ; adr-n n ;*** display the word name db RON, DUP, ROFF ; A A n db FCALL dw type.p ; A db LIT, ' ', EMIT ; A db DECR, DECR ; A-2 /point to next pointer db FETCH ; [A-2] db DUP ; *p *p db JUMPNZ, .again-$ ; *p db LIT, '#', EMIT db DROP ; clear zero pointer db EXIT listxt.doc: ; db ' ( adr -- ) ' ; db ' list all words by name and execution address ' ; dw $-listxt.doc listxt: dw list.p db 'listxt', 6 listxt.p: db FCALL dw last.p ; adr .again: db DUP ; adr adr db FCALL dw udot.p ; adr db LIT, ' ', EMIT ; print space db DECR db FCALL dw rcount.p ; a-n n ;*** display the word name db RON, DUP, ROFF ; A A n db FCALL dw type.p ; A db LIT, ' ', EMIT db DECR, DECR ; A-2 /point to next pointer db FETCH ; [A-2] db DUP ; *p *p db JUMPNZ, .again-$ ; *p db DROP ; clear 0 pointer db LIT, '~', EMIT db EXIT test.type.doc: ; db ' testing accept and type ' test.type: dw listxt.p db 'test.type', 9 test.type.p: db LIT, '>', EMIT ; db LITW dw term.d ; a db DUP ; a a db FCALL dw accept.p ; a db COUNT ; a+1 n ;*** show count of buffer db DUP ; a+1 n n db FCALL dw udot.p ; a+1 n db LIT, ':', EMIT ; a+1 n ;*** show contents of buffer db FCALL dw type.p db LIT, 13, EMIT ; db LIT, 10, EMIT ; db KEY, LIT, 13, EQUALS ; terminates db JUMPT, -28 db EXIT print.doc: ; db ' ( adr n -- adr n ) ' ; db ' same as type but doesnt alter stack ' ; db ' usefull for debugging ' ; dw $-print.doc print: dw test.type.p db 'print', 5 print.p: db TWODUP db FCALL dw type.p db EXIT type.doc: ; db ' ( adr n -- ) ' ; db ' Prints out n number of characters starting ' ; db ' at address adr. ' ; dw $-type.doc type: dw print.p db 'type', 4 type.p: ; adr n ;*** if count zero, do nothing db DUP ; adr n n db JUMPNZ, 5 ; adr n db DROP, DROP ; clear data stack db EXIT db RON ; adr r: n db CFETCHPLUS ; adr+1 c r: n db EMIT ; adr+1 r: n db RLOOP, -2 ; adr+1 r: n-1 db ROFF, DROP, DROP ; clear stacks db EXIT accept.doc: ; db ' ( buffer -- ) ; db ' receive a line of input from the terminal ' ; db ' and store it as a counted string in the buffer. ' ; db ' should have a character limit. backspaces are mainly ; db ' handled. ' ; dw $-accept.doc accept: dw type.p db 'accept', 6 accept.p: ;*** to elimate backspace problems, need to ; emit character after finding out what it is ; not before ; a db DUP, RON ; a r: a db INCR ; a+1 r: a db KEY, DUP ; a+1 c c r: a db DUP, EMIT ; a+1 c c r: a ;*** enter terminates input db LIT, 13, EQUALS; a+1 c flag r: a /enter press db JUMPT, 32 ; a+1 c r: a ;*** handle backspace db DUP ; a+1 c c r: a db LIT, 8, EQUALS ; a+1 c flag r: a /backspace db JUMPF, 22 ; a+1 c r: a db DROP ; a+1 r: a ;*** test for at 1st char db DUP ; a+1 a+1 r: a db ROFF, DUP, RON ; a+1 a+1 a r: a db MINUS ; a+1 n r: a db LIT, 1 ; a+1 n 1 r: a db EQUALS ; a+1 flag r: a db JUMPT, -24 ;*** not 1st char so go back 1 space db LIT, ' ', EMIT ; a+n r: a db LIT, 8, EMIT ; go back db DECR ; a+n-1 r: a db JUMP, -33 ; a+n-1 r: a /get next char db SWAP ; c a+1 r: a db CSTOREPLUS ; a+2 r: a db JUMP, -37 ; a+2 r: a ; a+n 13 r: a db LIT, 10, EMIT ; print newline if enter pressed db LIT, 13, EMIT ; db DROP ; a+n r: a db ROFF ; a+n a db DUP, RON ; a+n a r: a db MINUS ; n r: a db DECR ; n-1 r: a db ROFF ; n-1 a db CSTORE db EXIT in.doc: ; db ' ( -- adr ) ; db 'Puts on the stack the address of the ' ; db 'current input source/ buffer ' ; dw $-in.doc in: dw accept.p db 'in', 2 in.p: db LITW dw in.d db FETCH db EXIT in.d: dw 0 ; need to initialize term.doc: ; db ' ( -- adr ) ; db 'Puts on the stack the address of the ' ; db 'user input buffer (terminal buffer). This' ; db 'is a common source for interpreting and ' ; db ' compiling ' ; dw $-term.doc term: dw in.p db 'term', 4 term.p: db LITW dw term.d db EXIT term.d: times 64 db 0 ; counted buffer for user input dotin.doc: ; db ' ( -- ) ; db 'display the contents of the user terminal ' ; db 'input buffer ' ; dw $-dotin.doc dotin: dw term.p db '.in', 3 dotin.p: db LITW dw in.d ; adr db COUNT ; a+1 n db DUP ; a+1 n n db FCALL dw udot.p ; a+1 n db LIT, ':', EMIT ; a+1 n db FCALL dw type.p db EXIT ; : in.. in count dup u. sp type ; toin.doc: ; db ' ( -- adr n ) ' ; db ' put on stack parse position in input stream' ; db ' and number of characters remaining in stream. ' ; db ' This is used with parse etc' ; dw $-toin.doc ; was a strange bug with this link toin: dw dotin.p db '>in', 3 toin.p: ;** need to remember that toin.d and in.d are ; pointer and need to be fetched before use... *p ; db LITW dw toin.d ; adr db FETCH ; Ap db LITW dw in.d ; adr db FETCH ; Ap As db MINUS ; Ap-As db DECR ; Ap-As-1 /dont count 'count' byte db LITW dw in.d ; adr db FETCH ; Ap-As As db CFETCH ; m len db SWAP ; len m db MINUS ; len-m /remaining chars db LITW dw toin.d ; db FETCH ; n adr db SWAP ; adr n db EXIT toin.d: dw 0 ; maybe call this setin or in! instore atin.doc: ; db ' ( adr n -- ) ' ; db ' update word and parse position in input' ; db ' where the start of the word is given by pointer' ; db ' adr and the length of the word is n. The parse ' ; db ' position will be adr+n after this call ' ; db ' eg: pad resetin pad accept >in parse 2dup type ' ; db ' atin >in .s etc' ; dw $-atin.doc atin: dw toin.p db 'atin', 4 atin.p: ; adr n db SWAP, DUP ; n adr adr db LITW dw toword.d ; n adr adr a2 db STORE ; n adr db PLUS ; n+adr db LITW dw toin.d ; n+adr ap db STORE ; db EXIT resetin.doc: ; db ' ( adr -- ) ' ; db ' set word and parse position to 0 in input' ; db ' and set the input buffer to point to address ' ; db ' adr ' ; dw $-resetin.doc resetin: dw atin.p db 'resetin', 7 resetin.p: ; adr db DUP ; adr adr db LITW dw in.d ; adr adr in.d ;*** pointer to start of input stream -> in.d db STORE ; adr adr db INCR ; a+1 db LITW dw toin.d ; a+1 toin.d db STORE db LIT, 0 db LITW dw toword.d ; 0 in.nw db STORE db EXIT anon.doc: ; db ' ( -- adr ) ; db 'Puts on the stack the address of the ' ; db 'buffer to hold anonymous definitions. This ' ; db 'contains compiled byte code for user input ' ; dw $-anon.doc anon: dw resetin.p db 'anon', 4 anon.p: db LITW dw anon.d db EXIT anon.d: times 64 db 0 ; compiled byte code buff.doc: ; db ' ( -- adr ) ; db ' a testing buffer' ; dw $-buff.doc buff: dw anon.p db 'buff', 4 buff.p: db LITW dw buff.d db EXIT buff.d: times 64 db 0 ; compiled byte code pad.doc: ; db ' ( -- adr ) ; db 'Puts on the stack the address of the ' ; db 'general purpose text buffer ' ; dw $-pad.doc pad: dw buff.p db 'pad', 3 pad.p: db LITW dw pad.d db EXIT pad.d: times 64 db 0 one.doc: ; db ' A loop to compile and execute one word typed' ; db ' at the terminal and interpreted from the term.d' ; db ' buffer. The word can be either opcode ' ; db ' procedure or number ' one: dw pad.p db 'one', 3 one.p: db FCALL dw listxt.p db LIT, 10, EMIT db LIT, 13, EMIT .again: db LITW dw term.d db FCALL dw accept.p db LITW dw term.d ; adr db CFETCH ; n db JUMPZ, -10 ; db LITW dw term.d ; adr db COUNT ; adr+1 n db FCALL dw find.p ; xt db LIT, 'x', EMIT db LIT, 't', EMIT db LIT, '=', EMIT db DUP ; xt xt db FCALL dw udot.p ; xt db DUP ; xt xt db FCALL dw opcode.p ; xt op/0 db DUP ; xt op op db LIT, ' ', EMIT db LIT, 'o', EMIT db LIT, 'p', EMIT db LIT, '=', EMIT db FCALL dw udot.p ; xt op db LIT, ' ', EMIT ;*** check if valid opcode db DUP ; xt op op db JUMPZ, 17 ; xt op /opcode or procedure ;*** compile the bytecode to anon buffer db SWAP, DROP ; op db LITW dw anon.d ; op adr db CSTOREPLUS ; adr+1 db LIT, EXIT ; adr+1 n db SWAP ; n a+1 db CSTORE ; db FCALL dw anon.d db JUMP, 21 ; ;*** check if valid word ; xt op db DROP ; xt db DUP ; xt xt db JUMPZ, 19 ; xt ;**** here compile fcall and xt db LITW ; dw anon.d ; xt a db LIT, FCALL ; xt a n db SWAP ; xt n a db CSTOREPLUS ; xt a+1 db STOREPLUS ; a+4 db LIT, EXIT ; a+4 n db SWAP ; n a+4 db CSTORE ; db FCALL dw anon.d db JUMP, 43 ;*** check if valid number ; xt db DROP db LITW ; dw term.d ; adr db COUNT ; adr+1 n db FCALL dw tonumber.p ; a/n flag db JUMPNZ, 5 ; a/n db DROP ; db JUMP, 30 ; n ;*** valid number, so print db LIT, 'n', EMIT db LIT, '=', EMIT db DUP ; n n db FCALL dw udot.p ; n db LIT, ' ', EMIT db LITW ; dw anon.d ; n a db LIT, LITW ; n a op db SWAP ; n op a db CSTOREPLUS ; n a+1 db STOREPLUS ; a+3 db LIT, EXIT ; a+3 op db SWAP ; op a+3 db CSTORE ; db FCALL dw anon.d ; ; db LIT, 10, EMIT db LIT, 13, EMIT db LJUMP dw .again-$ db EXIT drive.doc: ; db ' ( -- adr ) ; db ' a variable to hold virtual drive number ' ; db ' but this should be an opcode ' ; drive: /another drive dw one.p db 'drive', 5 drive.p: db LITW dw drive.d ; ad db EXIT drive.d: db -1 lib.doc: ; db ' ( -- adr ) ; db ' some source code to load' ; dw $-lib.doc lib: dw drive.p db 'lib', 3 lib.p: db LITW dw lib.d db EXIT lib.d: db lib.end-$-1 db ' : K 1024 u* ; ' db ' : star 42 emit ; ' db ' : count c@+ ; ' db ' : sp 32 emit ; ' db ' : word... dup head. 20 decomp ; ' db ' : in.. in count dup u. sp type ; ' db ' : asc 1 begin dup u. sp dup emit sp 1+ dup 125 = until ; ' ; : word.. dup head. 20 decomp ; ; : in.. in count dup u. sp type ; lib.end: setlast.doc: ; db ' ( A -- ) ; db ' set last word point to address A ' setlast: dw lib.p db 'last!', 5 setlast.p: db LITW dw last.d ; A last db STORE ; db EXIT last.doc: ; db ' ( -- adr ) ; db 'Puts on the stack execution address of the last word ' ; db 'in the dictionary. This changes when new words are ' ; db 'added via colon : definitions ' last: dw setlast.p db 'last', 4 last.p: db LITW dw last.d ; ad db FETCH ; [ad] db EXIT last.d: dw last.p ; testing multisector stack machine byte code code: db FCALL dw interp.p db 0 start: mov ax, cs ; cs is already correct (?!) mov ds, ax ; data segment ;*** save the (virtual) drive we have loaded ; code from. Handy for disk writes later ; have to set data segment DS first mov [drive.d], byte dl ; ; point es:di directly after the code and data segment ; i.e. after the 8 sectors (8 * 512 bytes) ; which contain code and data. We will use es:di ; as the return stack pointer. When ; a value is pushed on the return stack, the value ; is written to [es:di] and di is incremented by 2 ; add ax, 256 ; 256 * 16 = 4096, 4K (8 sectors) ; put a gap of 4K between code and stacks for ; dictionary entries etc ;*** 8K code + 8K gap then rstack. But are the data and ; return stacks growing towards each other??? ;add ax, 512 ; 512 * 16 = 8K add ax, 1024 ; 1024 * 16 = 16K mov es, ax ; using es:di as return stack pointer mov di, 0 ; the calculations are as follows ; we have loaded 16 sectors = 16 * 512 bytes = 9162 bytes == 8K ; we want a data stack of size 4K ; (which is big) = 4094 bytes ; also we want a return stack of size 4K/8K ; for hefty recursive functions, although these ; huge sizes are not necessary. ; x86 hardware stack grows up or down? ... ; divide by 16 because that is how segment ; addressing works ; That is: if we multiply the number in ss or es ; or ds by 16 ; we get a absolute memory address ;*** ax is pointing to start of the rstack so ;*** add 4K more for data stack add ax, 256 ; 256*16=4K mov ss, ax ; a 4K stack here mov sp, 4096 ; set up the stack pointer push code call exec.x stayhere: jmp stayhere ;*** new words can be compiled here ; dictionary: dw 0 ; times 1024-($-$$) db 0 ; Pad sectors with 0s ; Pad remainder of 16 sectors with 0s times 8192-($-$$) db 0 ; MEMORY MAP (may 2018) ; This may change as code grows, but the idea is to keep code small ; The addresses below are segmented, so multiply the first part by ; 16 to get the real address. ; ; address contents ; ------- -------- ; 1000:0000 8K of code and data, including the dictionary ; and any new words defined by colon : ; ??:0000 8K return stack pointed to by es:di ; ??:0000 4K data stack pointed to by ss:sp ; times 4096 db 0 ;*** some text/forth code in sector 16+8 which we can load ;*** with source.p or with load opcode block.d: db 19, ' : star 42 emit ; '