type internal = Left | Right | Plus | Minus | Read | Write | Loop of internal list;; let internal_of_bf code = let addel el (x, l) = (x, el::l) in let len = String.length code in let rec cmp pos n = if pos < len then ( match code.[pos] with '<' -> addel Left (cmp (pos + 1) n) |'>' -> addel Right (cmp (pos + 1) n) |'+' -> addel Plus (cmp (pos + 1) n) |'-' -> addel Minus (cmp (pos + 1) n) |',' -> addel Read (cmp (pos + 1) n) |'.' -> addel Write (cmp (pos + 1) n) |'[' -> let (inrespos, inres) = (cmp (pos + 1) (n + 1)) in addel (Loop inres) (cmp inrespos n) |']' -> if n = 0 then failwith "unmatched closing bracket detected" else (pos + 1, []) |_ -> cmp (pos + 1) n ) else if n > 0 then failwith "unmatched opening bracket detected" else (pos + 1, []) in snd (cmp 0 0);; let asm_of_internal expr = let ptrs = ref 0 in let rec comp code = match code with |Left::ls -> " dec di\n" ^ (comp ls) |Right::ls -> " inc di\n" ^ (comp ls) |Plus::ls -> " inc byte ptr ds:di\n" ^ (comp ls) |Minus::ls -> " dec byte ptr ds:di\n" ^ (comp ls) |Read::ls -> " call read\n" ^ (comp ls) |Write::ls -> " call print\n" ^ (comp ls) |(Loop s)::ls -> incr ptrs; let sptrs = string_of_int !ptrs in ("op" ^ sptrs ^ ": cmp byte ptr di, 0\n je cl" ^ sptrs ^ "\n") ^ (comp s) ^ " jmp op" ^ sptrs ^ "\ncl" ^ sptrs ^ ":" ^ (comp ls) |[] -> "" in " use16 org 100h mov ax, cs cmp ax, 0A000h - 02000h jnc error add ax, 1000h mov ds, ax xor bx, bx erase: mov byte ptr ds:bx, 0 inc bx jnz erase xor di, di\n\n" ^ ((comp expr) ^ " jmp terminate print: mov dl, [ds:di] mov ah, 02h int 21h ret read: mov ah, 01h int 21h mov [ds:di], al ret error: mov dx, er_no_memory mov ah, 9 int 21h terminate: mov ah, 4ch int 21h er_no_memory: db 'Out of memory$'");; let compile code = asm_of_internal (internal_of_bf code);;