[ORG 0]

   jmp 07C0h:start         ; Goto segment 07C0
 
   ;*** aliases for each bytecode
   ; these aliases are in the
   ; same order as the pointer table below

   ;*** opcodes 1,2,3,4 etc
   DUP equ 1
   DROP equ DUP+1
   SWAP equ DROP+1
   CSTORE equ SWAP+1
   CFETCHPLUS equ CSTORE+1
   COUNT equ CFETCHPLUS     ; count is an alias for @+ 
   LIT equ COUNT+1
   LITW equ LIT+1
   EMIT equ LITW+1
   KEY equ EMIT+1
   PLUS equ KEY+1
   MINUS equ PLUS+1
   DIVMOD equ MINUS+1
   FCALL equ DIVMOD+1 
   EXIT equ FCALL+1 
   JUMP equ EXIT+1 
   JUMPZ equ JUMP+1 
   JUMPF equ JUMPZ      ; jump false alias for jump zero 
   ; JUMPNZ equ JUMPZ+1 
   NOOP equ JUMPZ +1    ; nop is a good end-marker

   ;*** a table of code pointers. 
   ;  The pointers have the same offset in
   ;  table as the value of the opcode
   op.table:
     dw 0, dup.x, drop.x, swap.x, cstore.x, cfetchplus.x
     dw lit.x, litw.x, emit.x, key.x
     dw plus.x, minus.x
     dw divmod.x, fcall.x, exit.x
     dw jump.x, jumpz.x

   ; 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
 
   ; using relative backlinks to previous dictionary 
   ; entry to save 1 byte, could squash a count in there
   ; as well maybe
   exec:
     db 0             ; zero link means top of dictionary
     db 'ex', 2       ; this is not used interactively
                      ; so probably doesnt need name field
   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

     ; what about eg pop fs
     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] ; opcode is offset into code *p table
     jmp .nextopcode
   .exit:
     ; or push fs
     push word [returnexec]     ; restore fn return ip
     ret

   returnexec dw 0

   plus.doc:
     ; db ' ( n1 n2 -- n1+n2 ) '
     ; db '  add the top 2 elements of the stack.'
     ; dw $-plus.doc
   plus:
     db $-exec.x-1    ; a relative link, saves 1 byte!
     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:
     db $-plus.x-1  ; relative backlink
     db '-', 1
   minus.x:
     pop dx      ; juggle return pointer
     pop bx
     pop ax
     sub ax, bx
     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:
     db $-minus.x-1
     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

   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:
     db $-divmod.x-1
     db 'fcall', 5
   fcall.x:
     lodsw     
     mov [es:di], si
     add di, 2
     mov si, ax      ; adjust the si code pointer 
     ret

   ; need to implement a return stack... maybe in DI
   ; destination ; index register.
   ; This will allow nested calls to procedures.
   
   exit.doc:
     ; db 'exit a virtual procedure by restoring si '
     ; db 'code pointer'
     ; dw $-exit.doc
   exit:
     ; not used interactively, so doesnt really need 
     ; name field
     db $-fcall.x-1
     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: 
     db $-exit.x-1
     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: 
     db $-dup.x-1     ; relative back-link 
     db 'drop', 4     ; strings may be '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: 
     db $-drop.x-1      ; link to previous word 
     db 'sw', 2
   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
 
   cstore.doc:
     ; db '( n addr -- ) '
     ; db 'store the byte value n at address adr.'
     ; db ' eg: 10 myvar c! '
     ; db '   puts the value 10 at the address specified 
     ; db '   by "myvar" '
     ; dw $-cstore.doc
   cstore: 
     db $-swap.x-1       ; 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
 
   cfetchplus.doc:

     ; db '( adr -- adr+1 n ) '
     ; db ' Replace top element of the stack with value '
     ; db ' of the byte at given memory address and +1'
     ; db ' address . This is the same as "count"'
     ; dw $-cfetchplus.doc

   cfetchplus: 
     db $-cstore.x-1      ; 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
 
   ; not used interactively so, probably doesnt
   ; need name field. Also probably doesnt need 
   ; link field either since it wont be looked up
   ; in the dictionary.
   lit.doc:
     ; db 'Pushes an 8 bit literal value onto the stack'
     ; db 'The literal value is encoded in the next byte '
     ; db 'after this instruction. This is similar to the '
     ; db 'forth "char" word. '
     ; dw $-lit.doc
   lit: 
     ;*** link field unnecessary ???
     ; db $-cfetchplus.x-1; relative backlink 
     ;*** name field unnecessary ???
     ; db 'lit', 3      
   lit.x:
     pop dx       ; juggle fn return address
     xor ax, ax   ; set ax := 0
     lodsb        ; al := [si]++ get literal char into AL 
     ; cbw        ; convert signed byte al to 
                  ; signed word ax (neg offset)
     push ax        ; put literal value on stack
     push dx        ; restore fn return address
     ret
 
   litw.doc:
     ; db 'Pushes an 16 bit literal value onto the stack'
     ; dw $-litw.doc
   litw: 
     ;*** link field unnecessary ???
     ;db $-lit.x-1     ; link to previous word 
     ;*** name field unnecessary ???
     ;db 'litw', 4     
   litw.x:
     pop dx         ; juggle fn return address
     lodsw          ; ax := [si]++ get literal char into AX
     push ax        ; put literal value on stack
     push dx        ; restore fn return address
     ret
 
   emit.doc:
     ; db 'displays top item on stack as an ascii character.'
     ; db 'char is in the low byte of the stack item...'
     ; dw $-emit.doc
   emit:
     db $-cfetchplus.x-1  ; skip lit/litw (not interactive)
     db 'emit', 4
   emit.x:
     pop bx         ; juggle return pointer
     pop ax         ; char in al
     push bx
     mov ah, 0x0E   ; bios teletype function 
     int 10h        ; x86 bios 
     ret

   key.doc:
     ; db 'Get one keystroke from user and place on stack'
     ; db 'The key is represented as an ascii code 
     ; db 'in the low byte of the stack item.'
     ; db 'might as well use ekey instead.'
     ; dw $-key.doc
   key: 
     db $-emit.x-1    ; relative link to prev
     db 'key', 3      ; reverse counted string
   key.x:
     mov ah, 0    ; wait for keypress bios function
     int 16h      ; ah := asci code and al := scan code
     pop bx       ; juggle function return pointer
     mov ah, 0    ; set ah = 0
     push ax      ; save asci code onto stack, high byte zero
     push bx      ; restore return pointer to stack
     ret

   jump.doc:
     ; db ' ( -- ) stack is unchanged.
     ; db ' Jumps to a relative virtual instruction.'
     ; db ' The relative jump is given in the next byte.'
     ; db ' eg: JUMP, -2, jumps back 2 instructions 
     ; db ' in the bytecode' 
     ; db ' eg: LIT, '*', EMIT, JUMP, -3, ' 
     ; db '  prints a never-ending list of asterixes '
     ; dw $-jump.doc
   jump: 
     ;*** not interactive so no link field
     ;db $-key.x-1  
     ;*** not interactive so no name field
     ;db 'j', 1    
   jump.x:
     xor ax, ax      ; set ax := 0
     lodsb           ; al := [si]++ get relative jump target into AL
     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
     ret

   jumpz.doc:
     ; db ' ( n -- )
     ; db 'jumps to a relative virtual instruction if top '
     ; db 'stack element is zero. The flag value is removed '
     ; db 'from the stack
     ; db ' The relative jump is given in the next byte.'
     ; db ' eg: JUMPZ, -2, jumps back 2 instructions in the bytecode' 
     ; db ' eg: KEY, DUP, EMIT, LIT, '0', MINUS, JUMPNZ, -6 ' 
     ; db '  allows the user to type until zero is pressed. '
     ; dw $-jump.doc
     ; 
     ; jumps are not used interactively so probably 
     ; dont need a name field.
   jumpz: 
     ;*** not interactive, no link/name field
     ;db $-jump.x-1
     ;db 'jz', 2  
   jumpz.x:
     pop dx        ; juggle return pointer
     xor ax, ax    ; set ax := 0
     lodsb         ; al := [si]++ relative jump target into AL

     ;*** check stack for zero, 
     ;    if not continue with next instruction 
     pop bx          ; get top stack item into bx
     cmp bx, 0       ; if dx != 0 continue
     jne .exit
     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

   read.doc:
     ; db ' ( sect n -- adr ) 
     ; db ' reads n sectors from disk starting at sect '
     ; db ' Return the address where sectors were loaded. '
     ; db ' In standard forths, load actually interprets '
     ; db ' source code. '
     ; dw $-read.doc
   read: 
     db $-key.x-1
     db 'r', 1
   read.x:
                      ; sect n
    .reset:           ; Reset the virtual floppy drive (usb)
      mov ax, 0       ; 
      mov dl, 0       ; assume drive is zero 
      ;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 512bytes, 
      ;    Load just after stack segment 
      mov ax, ss     ; cs is 07c0 hex ?! 
      mov es, ax     ; es:bx determines where data loaded to

      ;*** or ax=1100h bx=0 is 4K after 64K segment
      mov bx, 0      ; ES:BX = ss:0

      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

      ;*** 2 is first sector after 512byte 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] ; 
      mov dl, 0 ; 
      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 ss         ; return address where loaded  
      push dx         ; restore fn return
      ret

   ;*** load alters es (used for rstack) 
   ;*** need to save
   save.es: dw 0
   
   ; *******************************
   ; end of byte codes, 512 byte system
   ; *******************************

   ; see ddot.p below for how to rewrite this
   ; but we need >r r>. Or just print 5 digits always
   udot.doc:
     ; db ' ( n -- ) '
     ; db ' display top stack item as unsigned decimal. '
   udot:
     db $-read.x-1   ; skip jump/jumpz
     db 'u.', 2  
   udot.p:
     ; using 11 as a marker to know how many digits to print, but silly
     db LIT, 11, SWAP    ; 11 n
     db LIT, 10         ; 11 n 10
     db DIVMOD          ; 11 rem quotient
     db DUP, JUMPZ, 4
     db JUMP, -6
                       ; 11 rem rem rem ... 0
     db DROP           ; 11 rem rem ... 
     db LIT, '0', PLUS, EMIT   ; 11 rem ...  print remainder
     db DUP, LIT, 11, MINUS, JUMPZ, 4 
     db JUMP, -10
     db DROP
     db LIT, ' ', EMIT
     db EXIT 

   type.doc:
     ; db ' ( adr n -- ) '
     ; db ' Prints out n number of characters starting at address adr. '
   type:
     db $-udot.p-1 
     db 'type', 4
   type.p:         
                   ; adr n
   .nextchar:
     db SWAP       ; n adr 
     db CFETCHPLUS ; n adr+1 a
     db EMIT       ; n adr+1
     db SWAP       ; adr+1 n
     db LIT, 1     ; adr+1 n -1
     db MINUS      ; adr+1 n-1
     db DUP        ; adr+1 n-1 n-1
     db JUMPZ, 4   ; adr+1 n-1
     db JUMP, .nextchar-$
     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 ' This should be rewritten to discard excess chars.'
     ; also need to handle backspaces to backtrack over
     ; buffer
   accept:
     db $-type.p-1
     db 'ac', 2
   accept.p:      
                       ; ( adr -- )
     db DUP, DUP       ; a a a
   .nextchar:
     db LIT, 1, PLUS
     db DUP            ; a a a+1 a+1 
     db KEY            ; a a a+1 a+1 'x' 
     db DUP            ; a a a+1 a+1 'x' 'x'
     db EMIT, DUP      ; a a a+1 a+1 'x' 'x'
     db LIT, 13, MINUS, JUMPZ, 6  ;  a a a+1 a+1 'x'

     db SWAP              ; a a a+1 'x' a+1
     db CSTORE            ; a a a+1  /put char in buffer
     db JUMP, .nextchar-$ ; not newline so get another char
     db LIT, 10, EMIT     ; print newline if enter pressed
                          ; a a a+n a+n 'x'
     db DROP, DROP        ; a a a+n 
     db LIT, -1, PLUS     ; a a a+n-1 
     db SWAP, MINUS       ; a n-1
     db SWAP, CSTORE       ; [a] := n-1
     db EXIT    ; all virtual procedures end with 'exit'

   pad: db 9, 'alpha!'
   buff: db 0, '  '

   ; wow db KEY, EMIT, EXIT
   ; testing 512 one sector byte code

   code:

   .again:
     db LITW
     dw pad
     db CFETCHPLUS   
     db FCALL
     dw type.p
     db LITW
     dw pad
     db FCALL
     dw accept.p
     db LITW
     dw pad
     db CFETCHPLUS   
     db FCALL
     dw type.p
     db JUMP, .again-$

   start:

      ;mov ax, 07C0h ; Set data segment to where we're loaded
      mov ax, cs     ; cs already correct (07c0 hex ?!) 
      mov ds, ax     ; data segment  

      ;*** set up rstack *p (es:di) just after code
      add ax, 32       ; 32 * 16 = 512byte = 1 sector
      mov es, ax       ; using es:di as return stack pointer 
      mov di, 0

      ;*** cs/ss/ds/es * 16 gives absolute address
      add ax, 320      ; (4096+512+512)/16 
      mov ss, ax       ; a 4K stack here
      mov sp, 4096     ; set up the stack pointer

      push code 
      call exec.x

   forever:  jmp forever

   times 510-($-$$) db 0  ; Pad boot rest of sector with 0s
   dw 0xAA55              ; The standard PC boot signature

   ;db 'Something to load in 2nd Sector'