#lang typed/racket
;;;
;;; The Rosetta Code Virtual Machine, in Typed Racket.
;;;
;;; Migrated from the Common Lisp.
;;;

;;; Yes, I could compute how much memory is needed, or I could assume
;;; that the instructions are in address order. However, for *this*
;;; implementation I am going to use a large fixed-size memory and use
;;; the address fields of instructions to place the instructions.
(: executable-memory-size Positive-Fixnum)
(define executable-memory-size 65536)

;;; Similarly, I am going to have fixed size data and stack memory.
(: data-memory-size Positive-Fixnum)
(define data-memory-size 2048)
(: stack-memory-size Positive-Fixnum)
(define stack-memory-size 2048)

;;; And so I am going to have specialized types for the different
;;; kinds of memory the platform contains. Also for its "word" and
;;; register types.
(define-type Word Nonnegative-Fixnum)
(define-type Register (Boxof Word))
(define-type Executable-Memory (Mutable-Vectorof Byte))
(define-type Data-Memory (Mutable-Vectorof Word))
(define-type Stack-Memory (Mutable-Vectorof Word))

(define re-blank-line #px"^\\s*$")
(define re-parse-instr-1 #px"^\\s*(\\d+)\\s*(.*\\S)")
(define re-parse-instr-2 #px"(?i:^(\\S+)\\s*(.*))")
(define re-parse-instr-3 #px"^[[(]?([0-9-]+)")
(define re-header
  #px"(?i:^\\s*Datasize\\s*:\\s*(\\d+)\\s*Strings\\s*:\\s*(\\d+))")
(define re-leading-spaces #px"^\\s*")

(define opcode-names
  '("halt"
    "add"
    "sub"
    "mul"
    "div"
    "mod"
    "lt"
    "gt"
    "le"
    "ge"
    "eq"
    "ne"
    "and"
    "or"
    "neg"
    "not"
    "prtc"
    "prti"
    "prts"
    "fetch"
    "store"
    "push"
    "jmp"
    "jz"))

(: blank-line? (String -> Boolean))
(define (blank-line? s)
  (not (not (regexp-match re-blank-line s))))

(: opcode-from-name (String -> Byte))
(define (opcode-from-name s)
  (let ((i (index-of opcode-names s)))
    (assert i)
    (cast i Byte)))

(: create-executable-memory (-> Executable-Memory))
(define (create-executable-memory)
  (make-vector executable-memory-size (opcode-from-name "halt")))

(: create-data-memory (-> Data-Memory))
(define (create-data-memory)
  (make-vector data-memory-size 0))

(: create-stack-memory (-> Stack-Memory))
(define (create-stack-memory)
  (make-vector stack-memory-size 0))

(: create-register (-> Register))
(define (create-register)
  (box 0))

(struct machine
  ((sp : Register)   ; Stack pointer.
   (ip : Register)   ; Instruction pointer (that is, program counter).
   (code : Executable-Memory)
   (data : Data-Memory)
   (stack : Stack-Memory)
   (strings : (Immutable-Vectorof String))
   (output : Output-Port))
  #:type-name Machine
  #:constructor-name %make-machine)

(: make-machine ((Immutable-Vectorof String) Output-Port -> Machine))
(define (make-machine strings outf)
  (%make-machine (create-register)
                 (create-register)
                 (create-executable-memory)
                 (create-data-memory)
                 (create-stack-memory)
                 strings
                 outf))

(define-type Instruction-Data (List Word Byte (U False Word)))

(: insert-instruction (Executable-Memory Instruction-Data -> Void))
(define (insert-instruction memory instr)
  (void
   (match instr
     ((list address opcode arg)
      (let ((instr-size (if arg 5 1)))
        (unless (<= (+ address instr-size) executable-memory-size)
          (raise-user-error
           "the VM's executable memory size is exceeded"))
        (vector-set! memory address opcode)
        (when arg
          ;; Big-endian order.
          (vector-set! memory (+ address 1)
                       (bitwise-and (arithmetic-shift arg -24) #xFF))
          (vector-set! memory (+ address 2)
                       (bitwise-and (arithmetic-shift arg -16) #xFF))
          (vector-set! memory (+ address 3)
                       (bitwise-and (arithmetic-shift arg -8) #xFF))
          (vector-set! memory (+ address 4)
                       (bitwise-and arg #xFF))))))))

(: load-executable-memory (Executable-Memory
                           (Listof Instruction-Data) ->
                           Void))
(define (load-executable-memory memory instr-lst)
  (let loop ((p instr-lst))
    (if (null? p)
        (void)
        (let ((instr (car p)))
          (insert-instruction memory (car p))
          (loop (cdr p))))))

(: number->word (Number -> Word))
(define (number->word n)
  (cast (bitwise-and (cast n Integer) #xFFFFFFFF) Word))

(: string->word (String -> Word))
(define (string->word s)
  (let ((n (string->number s)))
    (assert (number? n))
    (number->word n)))

(: parse-instruction (String -> (U False Instruction-Data)))
(define (parse-instruction s)
  (and (not (blank-line? s))
       (let* ((strings (cast (regexp-match re-parse-instr-1 s)
                             (Listof String)))
              (address (cast (string->number (second strings))
                             Word))
              (split (cast (regexp-match re-parse-instr-2
                                         (third strings))
                           (Listof String)))
              (opcode-name (string-downcase (second split)))
              (opcode (opcode-from-name opcode-name))
              (arguments (third split))
              (has-arg? (match opcode-name
                          ((or "fetch" "store" "push" "jmp" "jz") #t)
                          (_ #f))))
         (if has-arg?
             (let* ((argstr-lst
                     (cast (regexp-match re-parse-instr-3 arguments)
                           (Listof String)))
                    (argstr (second argstr-lst))
                    (arg (string->word argstr)))
               `(,address ,opcode ,arg))
             `(,address ,opcode #f)))))

(: read-instructions (Input-Port -> (Listof Instruction-Data)))
(define (read-instructions inpf)
  (let loop ((line (read-line inpf))
             (lst (cast '() (Listof Instruction-Data))))
    (if (eof-object? line)
        (reverse lst)
        (let ((instr (parse-instruction line)))
          (loop (read-line inpf)
                (if instr
                    (cons instr lst)
                    lst))))))

(: read-datasize-and-strings-count (Input-Port -> (Values Word Word)))
(define (read-datasize-and-strings-count inpf)
  (let ((line (read-line inpf)))
    (unless (string? line)
      (raise-user-error "empty input"))
    ;; This is a permissive implementation.
    (let* ((strings (cast (regexp-match re-header line)
                          (Listof String)))
           (datasize (string->word (second strings)))
           (strings-count (string->word (third strings))))
      (values datasize strings-count))))

(: parse-string-literal (String -> String))
(define (parse-string-literal s)
  ;; This is a permissive implementation, but only in that it skips
  ;; any leading space. It does not check carefully for outright
  ;; mistakes.
  (let* ((s (regexp-replace re-leading-spaces s ""))
         (quote-mark (string-ref s 0)))
    (let loop ((i 1)
               (lst (cast '() (Listof Char))))
      (if (char=? (string-ref s i) quote-mark)
          (list->string (reverse lst))
          (let ((c (string-ref s i)))
            (if (char=? c #\\)
                (let ((c0 (match (string-ref s (+ i 1))
                            (#\n #\newline)
                            (c1 c1))))
                  (loop (+ i 2) (cons c0 lst)))
                (loop (+ i 1) (cons c lst))))))))

(: read-string-literals (Input-Port Word -> (Listof String)))
(define (read-string-literals inpf strings-count)
  (for/list ((i (in-range strings-count)))
    (let ((line (read-line inpf)))
      (begin (assert (string? line))
             (parse-string-literal line)))))

(: open-inpf (String -> Input-Port))
(define (open-inpf inpf-filename)
  (if (string=? inpf-filename "-")
      (current-input-port)
      (open-input-file inpf-filename)))

(: open-outf (String -> Output-Port))
(define (open-outf outf-filename)
  (if (string=? outf-filename "-")
      (current-output-port)
      (open-output-file outf-filename #:exists 'truncate)))

(: word-signbit? (Word -> Boolean))
(define (word-signbit? x)
  ;; True if and only if the sign bit is set.
  (not (zero? (bitwise-and x #x80000000))))

(: word-add (Word Word -> Word))
(define (word-add x y)
  ;; Addition with overflow freely allowed.
  (cast (bitwise-and (+ x y) #xFFFFFFFF) Word))

(: word-neg (Word -> Word))
(define (word-neg x)
  ;; The two's complement.
  (word-add (cast (bitwise-xor x #xFFFFFFFF) Word) 1))

(: word-sub (Word Word -> Word))
(define (word-sub x y)
  ;; Subtraction with overflow freely allowed.
  (word-add x (word-neg y)))

(: word-mul (Word Word -> Word))
(define (word-mul x y)
  ;; Signed multiplication.
  (let ((x<0 (word-signbit? x))
        (y<0 (word-signbit? y)))
    (let ((abs-x (if x<0 (word-neg x) x))
          (abs-y (if y<0 (word-neg y) y)))
      (let* ((abs-xy (cast (bitwise-and (* abs-x abs-y) #xFFFFFFFF)
                           Word)))
        (if x<0
            (if y<0 abs-xy (word-neg abs-xy))
            (if y<0 (word-neg abs-xy) abs-xy))))))

(: word-div (Word Word -> Word))
(define (word-div x y)
  ;; The quotient after signed integer division with truncation
  ;; towards zero.
  (let ((x<0 (word-signbit? x))
        (y<0 (word-signbit? y)))
    (let ((abs-x (if x<0 (word-neg x) x))
          (abs-y (if y<0 (word-neg y) y)))
      (let* ((abs-x/y (cast (bitwise-and (quotient abs-x abs-y)
                                         #xFFFFFFFF)
                            Word)))
        (if x<0
            (if y<0 abs-x/y (word-neg abs-x/y))
            (if y<0 (word-neg abs-x/y) abs-x/y))))))

(: word-mod (Word Word -> Word))
(define (word-mod x y)
  ;; The remainder after signed integer division with truncation
  ;; towards zero.
  (let ((x<0 (word-signbit? x))
        (y<0 (word-signbit? y)))
    (let ((abs-x (if x<0 (word-neg x) x))
          (abs-y (if y<0 (word-neg y) y)))
      (let* ((abs-x/y (cast (bitwise-and (remainder abs-x abs-y)
                                         #xFFFFFFFF)
                            Word)))
        (if x<0
            (if y<0 abs-x/y (word-neg abs-x/y))
            (if y<0 (word-neg abs-x/y) abs-x/y))))))

(: b2i (Boolean -> (U Zero One)))
(define (b2i b)
  (if b 1 0))

(: word-lt (Word Word -> Word))
(define (word-lt x y)
  ;; Signed comparison: is x less than y?
  (let ((x<0 (word-signbit? x))
        (y<0 (word-signbit? y)))
    (b2i (if x<0
             (if y<0 (< x y) #t)
             (if y<0 #f (< x y))))))

(: word-le (Word Word -> Word))
(define (word-le x y)
  ;; Signed comparison: is x less than or equal to y?
  (let ((x<0 (word-signbit? x))
        (y<0 (word-signbit? y)))
    (b2i (if x<0
             (if y<0 (<= x y) #t)
             (if y<0 #f (<= x y))))))

(: word-gt (Word Word -> Word))
(define (word-gt x y)
  ;; Signed comparison: is x greater than y?
  (let ((x<0 (word-signbit? x))
        (y<0 (word-signbit? y)))
    (b2i (if x<0
             (if y<0 (> x y) #f)
             (if y<0 #t (> x y))))))

(: word-ge (Word Word -> Word))
(define (word-ge x y)
  ;; Signed comparison: is x greater than or equal to y?
  (let ((x<0 (word-signbit? x))
        (y<0 (word-signbit? y)))
    (b2i (if x<0
             (if y<0 (>= x y) #f)
             (if y<0 #t (>= x y))))))

(: word-eq (Word Word -> Word))
(define (word-eq x y)
  ;; Is x equal to y?
  (b2i (= x y)))

(: word-ne (Word Word -> Word))
(define (word-ne x y)
  ;; Is x not equal to y?
  (b2i (not (= x y))))

(: word-cmp (Word -> Word))
(define (word-cmp x)
  ;; The logical complement.
  (b2i (zero? x)))

(: word-and (Word Word -> Word))
(define (word-and x y)
  ;; The logical conjunction.
  (b2i (and (not (zero? x)) (not (zero? y)))))

(: word-or (Word Word -> Word))
(define (word-or x y)
  ;; The logical disjunction.
  (b2i (or (not (zero? x)) (not (zero? y)))))

(: unop (Stack-Memory Register (Word -> Word) -> Void))
(define (unop stack sp operation)
  ;; Perform a unary operation on the stack.
  (let ((i (unbox sp)))
    (unless (<= 1 i)
      (raise-user-error "stack underflow"))
    (let ((x (vector-ref stack (- i 1))))
      ;; Note how, in contrast to Common Lisp, "operation" is not in a
      ;; namespace separate from that of "ordinary" values, such as
      ;; numbers and strings. (Which way is "better" is a matter of
      ;; taste, and probably depends mostly on what "functional"
      ;; language one learnt first. Mine was Caml Light, so I prefer
      ;; the Scheme way. :) )
      (vector-set! stack (- i 1) (operation x)))))

(: binop (Stack-Memory Register (Word Word -> Word) -> Void))
(define (binop stack sp operation)
  ;; Perform a binary operation on the stack.
  (let ((i (unbox sp)))
    (unless (<= 2 i)
      (raise-user-error "stack underflow"))
    (let ((x (vector-ref stack (- i 2)))
          (y (vector-ref stack (- i 1))))
      (vector-set! stack (- i 2) (operation x y)))
    (set-box! sp (cast (- i 1) Word))))

(: jri (Executable-Memory Register -> Void))
(define (jri code ip)
  ;; Jump relative immediate.
  (let ((j (unbox ip)))
    (unless (<= (+ j 4) executable-memory-size)
      (raise-user-error "address past end of executable memory"))
    ;; Big-endian order.
    (let* ((offset (vector-ref code (+ j 3)))
           (offset (bitwise-ior
                    (arithmetic-shift (vector-ref code (+ j 2)) 8)
                    offset))
           (offset (bitwise-ior
                    (arithmetic-shift (vector-ref code (+ j 1)) 16)
                    offset))
           (offset (bitwise-ior
                    (arithmetic-shift (vector-ref code j) 24)
                    offset)))
      (set-box! ip (word-add j (cast offset Word))))))

(: jriz (Stack-Memory Register Executable-Memory Register -> Void))
(define (jriz stack sp code ip)
  ;; Jump relative immediate, if zero.
  (let ((i (unbox sp)))
    (unless (<= 1 i)
      (raise-user-error "stack underflow"))
    (let ((x (vector-ref stack (- i 1))))
      (set-box! sp (- i 1))
      (if (zero? x)
          (jri code ip)
          (let ((j (unbox ip)))
            (set-box! ip (cast (+ j 4) Word)))))))

(: get-immediate-value (Executable-Memory Register -> Word))
(define (get-immediate-value code ip)
  (let ((j (unbox ip)))
    (unless (<= (+ j 4) executable-memory-size)
      (raise-user-error "address past end of executable memory"))
    ;; Big-endian order.
    (let* ((x (vector-ref code (+ j 3)))
           (x (bitwise-ior
               (arithmetic-shift (vector-ref code (+ j 2)) 8)
               x))
           (x (bitwise-ior
               (arithmetic-shift (vector-ref code (+ j 1)) 16)
               x))
           (x (bitwise-ior
               (arithmetic-shift (vector-ref code j) 24)
               x)))
      (set-box! ip (cast (+ j 4) Word))
      (cast x Word))))

(: pushi (Stack-Memory Register Executable-Memory Register -> Void))
(define (pushi stack sp code ip)
  ;; Push-immediate a value from executable memory onto the stack.
  (let ((i (unbox sp)))
    (unless (< i stack-memory-size)
      (raise-user-error "stack overflow"))
    (vector-set! stack i (get-immediate-value code ip))
    (set-box! sp (cast (+ i 1) Word))))

(: fetch (Stack-Memory
          Register Executable-Memory Register
          Data-Memory -> Void))
(define (fetch stack sp code ip data)
  ;; Fetch data to the stack, using the storage location given in
  ;; executable memory.
  (let ((i (unbox sp)))
    (unless (< i stack-memory-size)
      (raise-user-error "stack overflow"))
    (let* ((k (get-immediate-value code ip))
           (x (vector-ref data k)))
      (vector-set! stack i x)
      (set-box! sp (cast (+ i 1) Word)))))

(: pop-one (Stack-Memory Register -> Word))
(define (pop-one stack sp)
  (let ((i (unbox sp)))
    (unless (<= 1 i)
      (raise-user-error "stack underflow"))
    (let* ((x (vector-ref stack (- i 1))))
      (set-box! sp (- i 1))
      x)))

(: store (Stack-Memory
          Register Executable-Memory Register
          Data-Memory -> Void))
(define (store stack sp code ip data)
  ;; Store data from the stack, using the storage location given in
  ;; executable memory.
  (let ((i (unbox sp)))
    (unless (<= 1 i)
      (raise-user-error "stack underflow"))
    (let ((k (get-immediate-value code ip))
          (x (pop-one stack sp)))
      (vector-set! data k x))))

(: prti (Stack-Memory Register Output-Port -> Void))
(define (prti stack sp outf)
  ;; Print the top value of the stack, as a signed decimal value.
  (let* ((n (pop-one stack sp))
         (n<0 (word-signbit? n)))
    (if n<0
        (begin (display "-" outf)
               (display (word-neg n) outf))
        (display n outf))))

(: prtc (Stack-Memory Register Output-Port -> Void))
(define (prtc stack sp outf)
  ;; Print the top value of the stack, as a character.
  (let ((c (pop-one stack sp)))
    (display (integer->char c) outf)))

(: prts (Stack-Memory
         Register (Immutable-Vectorof String) Output-Port -> Void))
(define (prts stack sp strings outf)
  ;; Print the string specified by the top of the stack.
  (let* ((k (pop-one stack sp))
         (s (vector-ref strings k)))
    (display s outf)))

;;
;; I have written macros in the standard R6RS fashion, with a lambda
;; and syntax-case, so the examples may be widely illustrative. Racket
;; supports this style, despite (purposely) not adhering to any Scheme
;; standard.
;;
;; Some Schemes that do not provide syntax-case (CHICKEN, for
;; instance) provide alternatives that may be quite different.
;;
;; R5RS and R7RS require only syntax-rules, which cannot do what we
;; are doing here. (What we are doing is similar to using ## in a
;; modern C macro, except that the pieces are not merely raw text, and
;; they must be properly typed at every stage.)
;;
(define-syntax define-machine-binop
  (lambda (stx)
    (syntax-case stx ()
      ((_ op)
       (let* ((op^ (syntax->datum #'op))
              (machine-op (string-append "machine-" op^))
              (machine-op (string->symbol machine-op))
              (machine-op (datum->syntax stx machine-op))
              (word-op (string-append "word-" op^))
              (word-op (string->symbol word-op))
              (word-op (datum->syntax stx word-op)))
         #`(begin
             (: #,machine-op (Machine -> Void))
             (define (#,machine-op mach)
               (binop (machine-stack mach)
                      (machine-sp mach)
                      #,word-op))))))))

(define-syntax define-machine-unop
  (lambda (stx)
    (syntax-case stx ()
      ((_ op)
       (let* ((op^ (syntax->datum #'op))
              (machine-op (string-append "machine-" op^))
              (machine-op (string->symbol machine-op))
              (machine-op (datum->syntax stx machine-op))
              (word-op (string-append "word-" op^))
              (word-op (string->symbol word-op))
              (word-op (datum->syntax stx word-op)))
         #`(begin
             (: #,machine-op (Machine -> Void))
             (define (#,machine-op mach)
               (unop (machine-stack mach)
                     (machine-sp mach)
                     #,word-op))))))))

(define-machine-binop "add")
(define-machine-binop "sub")
(define-machine-binop "mul")
(define-machine-binop "div")
(define-machine-binop "mod")
(define-machine-binop "lt")
(define-machine-binop "gt")
(define-machine-binop "le")
(define-machine-binop "ge")
(define-machine-binop "eq")
(define-machine-binop "ne")
(define-machine-binop "and")
(define-machine-binop "or")

(define-machine-unop "neg")

(: machine-not (Machine -> Void))
(define (machine-not mach)
  (unop (machine-stack mach)
        (machine-sp mach)
        word-cmp))

(: machine-prtc (Machine -> Void))
(define (machine-prtc mach)
  (prtc (machine-stack mach)
        (machine-sp mach)
        (machine-output mach)))

(: machine-prti (Machine -> Void))
(define (machine-prti mach)
  (prti (machine-stack mach)
        (machine-sp mach)
        (machine-output mach)))

(: machine-prts (Machine -> Void))
(define (machine-prts mach)
  (prts (machine-stack mach)
        (machine-sp mach)
        (machine-strings mach)
        (machine-output mach)))

(: machine-fetch (Machine -> Void))
(define (machine-fetch mach)
  (fetch (machine-stack mach)
         (machine-sp mach)
         (machine-code mach)
         (machine-ip mach)
         (machine-data mach)))

(: machine-store (Machine -> Void))
(define (machine-store mach)
  (store (machine-stack mach)
         (machine-sp mach)
         (machine-code mach)
         (machine-ip mach)
         (machine-data mach)))

(: machine-push (Machine -> Void))
(define (machine-push mach)
  (pushi (machine-stack mach)
         (machine-sp mach)
         (machine-code mach)
         (machine-ip mach)))

(: machine-jmp (Machine -> Void))
(define (machine-jmp mach)
  (jri (machine-code mach)
       (machine-ip mach)))

(: machine-jz (Machine -> Void))
(define (machine-jz mach)
  (jriz (machine-stack mach)
        (machine-sp mach)
        (machine-code mach)
        (machine-ip mach)))

(: get-opcode (Machine -> Byte))
(define (get-opcode mach)
  (let ((code (machine-code mach))
        (ip (machine-ip mach)))
    (let ((j (unbox ip)))
      (unless (< j executable-memory-size)
        (raise-user-error "address past end of executable memory"))
      (let ((opcode (vector-ref code j)))
        (set-box! ip (cast (+ j 1) Word))
        opcode))))

(: run-instruction (Machine Byte -> Void))
(define (run-instruction mach opcode)
  (let ((op-mod-4 (bitwise-and opcode #x3))
        (op-div-4 (arithmetic-shift opcode -2)))
    (match op-div-4
      (0 (match op-mod-4
           (1 (machine-add mach))
           (2 (machine-sub mach))
           (3 (machine-mul mach))))
      (1 (match op-mod-4
           (0 (machine-div mach))
           (1 (machine-mod mach))
           (2 (machine-lt mach))
           (3 (machine-gt mach))))
      (2 (match op-mod-4
           (0 (machine-le mach))
           (1 (machine-ge mach))
           (2 (machine-eq mach))
           (3 (machine-ne mach))))
      (3 (match op-mod-4
           (0 (machine-and mach))
           (1 (machine-or mach))
           (2 (machine-neg mach))
           (3 (machine-not mach))))
      (4 (match op-mod-4
           (0 (machine-prtc mach))
           (1 (machine-prti mach))
           (2 (machine-prts mach))
           (3 (machine-fetch mach))))
      (5 (match op-mod-4
           (0 (machine-store mach))
           (1 (machine-push mach))
           (2 (machine-jmp mach))
           (3 (machine-jz mach)))))))

(: run-vm (Machine -> Void))
(define (run-vm mach)
  (let ((opcode-for-halt (cast (opcode-from-name "halt") Byte))
        (opcode-for-add (cast (opcode-from-name "add") Byte))
        (opcode-for-jz (cast (opcode-from-name "jz") Byte)))
    (let loop ((opcode (get-opcode mach)))
      (unless (= opcode opcode-for-halt)
        (begin
          (when (or (< opcode opcode-for-add)
                    (< opcode-for-jz opcode))
            (raise-user-error "unsupported opcode"))
          (run-instruction mach opcode)
          (loop (get-opcode mach)))))))

(define (usage-error)
  (display "Usage: vm [INPUTFILE [OUTPUTFILE]]" (current-error-port))
  (newline (current-error-port))
  (display "If either INPUTFILE or OUTPUTFILE is \"-\", the respective"
           (current-error-port))
  (display " standard I/O is used." (current-error-port))
  (newline (current-error-port))
  (exit 1))

(: get-filenames (-> (Values String String)))
(define (get-filenames)
  (match (current-command-line-arguments)
    ((vector) (values "-" "-"))
    ((vector inpf-filename)
     (values (cast inpf-filename String) "-"))
    ((vector inpf-filename outf-filename)
     (values (cast inpf-filename String)
             (cast outf-filename String)))
    (_ (usage-error)
       (values "" ""))))

(let-values (((inpf-filename outf-filename) (get-filenames)))
  (let* ((inpf (open-inpf inpf-filename))
         (outf (open-outf outf-filename)))
    (let-values (((datasize strings-count)
                  (read-datasize-and-strings-count inpf)))
      (let* ((strings
              (vector->immutable-vector
               (list->vector
                (read-string-literals inpf strings-count))))
             (instructions (read-instructions inpf))

             (mach (make-machine strings outf)))

        (unless (<= datasize data-memory-size)
          (raise-user-error
           "the VM's data memory size is exceeded"))

        (load-executable-memory (machine-code mach) instructions)
        (run-vm mach)

        (unless (string=? inpf-filename "-")
          (close-input-port inpf))
        (unless (string=? outf-filename "-")
          (close-output-port outf))

        (exit 0)))))


input = [
    ["pi=3.14159265358979323846264338327950288419716939937510582097494459231", " ", 5],
    [raw"The author has two Z$100000000000000 Zimbabwe notes (100 trillion).", "."],
    [raw"-in Aus$+1411.8millions"],
    [raw"===US$0017440 millions=== (in 2000 dollars)"],
    ["123.e8000 is pretty big."],
    ["The land area of the earth is  57268900(29% of the surface)  square miles."],
    ["Ain\'t no numbers in this here words, nohow, no way, Jose."],
    ["James was never known as  0000000007"],
    ["Arthur Eddington wrote: I believe there are 15747724136275002577605653961181555468044717914527116709366231425076185631031296 protons in the universe."],
    [raw"   $-140000±100  millions."],
    ["6/9/1946 was a good year for some."]]

function commatize(tst)
    grouping = (length(tst) == 3) ? tst[3] : 3
    sep = (length(tst) > 1) ? tst[2] : ","
    rmend(s) = replace(s, Regex("$sep\\Z") =>"")
    greg = Regex(".{$grouping}")
    cins(str) = reverse(rmend(replace(reverse(str), greg => s -> s * sep)))
    mat = match(Regex("(?<![eE\\/])([1-9]\\d{$grouping,})"), tst[1])
    if mat != nothing
        return replace(tst[1], mat.match => cins)
    end
    return tst[1]
end

for tst in input
    println(commatize(tst))
end


// version 1.1.4-3

val r = Regex("""(\.[0-9]+|[1-9]([0-9]+)?(\.[0-9]+)?)""")

fun String.commatize(startIndex: Int = 0, period: Int = 3, sep: String = ","): String {
    if ((startIndex !in 0 until this.length) || period < 1 || sep == "") return this
    val m = r.find(this, startIndex)
    if (m == null) return this
    val splits = m.value.split('.')
    var ip = splits[0]
    if (ip.length > period) {
        val sb = StringBuilder(ip.reversed())
        for (i in (ip.length - 1) / period * period downTo period step period) {
            sb.insert(i, sep)
        }
        ip = sb.toString().reversed()
    }
    if ('.' in m.value) {
        var dp = splits[1]
        if (dp.length > period) {
            val sb2 = StringBuilder(dp)
            for (i in (dp.length - 1) / period * period downTo period step period) {
                sb2.insert(i, sep)
            }
            dp = sb2.toString()
        }
        ip += "." + dp
    }
    return this.take(startIndex) + this.drop(startIndex).replaceFirst(m.value, ip)
}

fun main(args: Array<String>) {
    val tests = arrayOf(
        "123456789.123456789",
        ".123456789",
        "57256.1D-4",
        "pi=3.14159265358979323846264338327950288419716939937510582097494459231",
        "The author has two Z$100000000000000 Zimbabwe notes (100 trillion).",
        "-in Aus$+1411.8millions",
        "===US$0017440 millions=== (in 2000 dollars)",
        "123.e8000 is pretty big.",
        "The land area of the earth is 57268900(29% of the surface) square miles.",
        "Ain't no numbers in this here words, nohow, no way, Jose.",
        "James was never known as 0000000007",
        "Arthur Eddington wrote: I believe there are " +
        "15747724136275002577605653961181555468044717914527116709366231425076185631031296" +
        " protons in the universe.",
        "   $-140000±100 millions.",
        "6/9/1946 was a good year for some."
    )

    println(tests[0].commatize(period = 2, sep = "*"))
    println(tests[1].commatize(period = 3, sep = "-"))
    println(tests[2].commatize(period = 4, sep = "__"))
    println(tests[3].commatize(period = 5, sep = " "))
    println(tests[4].commatize(sep = "."))
    for (test in tests.drop(5)) println(test.commatize())
}


        >>SOURCE FORMAT IS FREE
identification division.
*> this code is dedicated to the public domain
*> (GnuCOBOL) 2.3-dev.0
program-id. generator.
environment division.
configuration section.
repository.  function all intrinsic.
data division.
working-storage section.
01  program-name pic x(32) value spaces global.
01  input-name pic x(32) value spaces global.
01  input-status pic xx global.

01  ast-record global.
    03  ast-type pic x(14).
    03  ast-value pic x(48).
    03  filler redefines ast-value.
        05  asl-left pic 999.
        05  asl-right pic 999.

01  error-record pic x(64) value spaces global.

01  loadstack global.
    03  l pic 99 value 0.
    03  l-lim pic 99 value 64.
    03  load-entry occurs 64.
        05  l-node pic x(14).
        05  l-left pic 999.
        05  l-right pic 999.
        05  l-link pic 999.

01  abstract-syntax-tree global.
    03  t pic 999 value 0.
    03  t1 pic 999.
    03  t-lim pic 999 value 998.
    03  filler occurs 998.
        05  p1 pic 999.
        05  p2 pic 999.
        05  p3 pic 999.
        05  n1 pic 999.
        05  leaf.
            07  leaf-type pic x(14).
            07  leaf-value pic x(48).
        05  node redefines leaf.
            07  node-type pic x(14).
            07  node-left pic 999.
            07  node-right pic 999.

01  opcodes global.
    03  opFETCH pic x value x'00'.
    03  opSTORE pic x value x'01'.
    03  opPUSH  pic x value x'02'.
    03  opADD   pic x value x'03'.
    03  opSUB   pic x value x'04'.
    03  opMUL   pic x value x'05'.
    03  opDIV   pic x value x'06'.
    03  opMOD   pic x value x'07'.
    03  opLT    pic x value x'08'.
    03  opGT    pic x value x'09'.
    03  opLE    pic x value x'0A'.
    03  opGE    pic x value x'0B'.
    03  opEQ    pic x value x'0C'.
    03  opNE    pic x value x'0D'.
    03  opAND   pic x value x'0E'.
    03  opOR    pic x value x'0F'.
    03  opNEG   pic x value x'10'.
    03  opNOT   pic x value x'11'.
    03  opJMP   pic x value x'13'.
    03  opJZ    pic x value x'14'.
    03  opPRTC  pic x value x'15'.
    03  opPRTS  pic x value x'16'.
    03  opPRTI  pic x value x'17'.
    03  opHALT  pic x value x'18'.

01  variables global.
    03  v pic 99.
    03  v-max pic 99 value 0.
    03  v-lim pic 99 value 16.
    03  variable-entry occurs 16 pic x(48).

01  strings global.
    03  s pic 99.
    03  s-max pic 99 value 0.
    03  s-lim pic 99 value 16.
    03  string-entry occurs 16 pic x(48).

01  generated-code global.
    03  c  pic 999 value 1.
    03  c1 pic 999.
    03  c-lim pic 999 value 512.
    03  kode pic x(512).

procedure division chaining program-name.
start-generator.
    call 'loadast'
    if program-name <> spaces
        call 'readinput' *> close input-file
    end-if
    >>d perform print-ast
    call 'codegen' using t
    call 'emitbyte' using opHALT
    >>d call 'showhex' using kode c
    call 'listcode'
    stop run
    .
print-ast.
    call 'printast' using t
    display 'ast:' upon syserr
    display 't=' t
    perform varying t1 from 1 by 1 until t1 > t
        if leaf-type(t1) = 'Identifier' or 'Integer' or 'String'
            display t1 space trim(leaf-type(t1)) space trim(leaf-value(t1)) upon syserr
        else
            display t1 space node-left(t1) space node-right(t1) space trim(node-type(t1))
                upon syserr
        end-if
    end-perform
    .
identification division.
program-id. codegen common recursive.
data division.
working-storage section.
01  r pic ---9.
linkage section.
01  n pic 999.
procedure division using n.
start-codegen.
    if n = 0
        exit program
    end-if
    >>d display 'at 'c ' node=' space n space node-type(n) upon syserr
    evaluate node-type(n)
    when 'Identifier'
        call 'emitbyte' using opFetch
        call 'variableoffset' using leaf-value(n)
        call 'emitword' using v '0'
    when 'Integer'
        call 'emitbyte' using opPUSH
        call 'emitword' using leaf-value(n) '0'
    when 'String'
        call 'emitbyte' using opPUSH
        call 'stringoffset' using leaf-value(n)
        call 'emitword' using s '0'
    when 'Assign'
        call 'codegen' using node-right(n)
        call 'emitbyte' using opSTORE
        move node-left(n) to n1(n)
        call 'variableoffset' using leaf-value(n1(n))
        call 'emitword' using v '0'
    when 'If'
        call 'codegen' using node-left(n)          *> conditional expr
        call 'emitbyte' using opJZ                 *> jump to false path or exit
        move c to p1(n)
        call 'emitword' using '0' '0'
        move node-right(n) to n1(n)                *> true path
        call 'codegen' using node-left(n1(n))
        if node-right(n1(n)) <> 0                  *> there is a false path
            call 'emitbyte' using opJMP            *> jump past false path
            move c to p2(n)
            call 'emitword' using '0' '0'
            compute r = c - p1(n)                  *> fill in jump to false path
            call 'emitword' using r p1(n)
            call 'codegen' using node-right(n1(n)) *> false path
            compute r = c - p2(n)                  *> fill in jump to exit
            call 'emitword' using r p2(n)
        else
            compute r = c - p1(n)
            call 'emitword' using r p1(n)          *> fill in jump to exit
        end-if
    when 'While'
        move c to p3(n)                            *> save address of while start
        call 'codegen' using node-left(n)          *> conditional expr
        call 'emitbyte' using opJZ                 *> jump to exit
        move c to p2(n)
        call 'emitword' using '0' '0'
        call 'codegen' using node-right(n)         *> while body
        call 'emitbyte' using opJMP                *> jump to while start
        compute r = p3(n) - c
        call 'emitword' using r '0'
        compute r = c - p2(n)                      *> fill in jump to exit
        call 'emitword' using r p2(n)
    when 'Sequence'
        call 'codegen' using node-left(n)
        call 'codegen' using node-right(n)
    when 'Prtc'
        call 'codegen' using node-left(n)
        call 'emitbyte' using opPRTC
    when 'Prti'
        call 'codegen' using node-left(n)
        call 'emitbyte' using opPRTI
    when 'Prts'
        call 'codegen' using node-left(n)
        call 'emitbyte' using opPRTS
    when 'Less'
        call 'codegen' using node-left(n)
        call 'codegen' using node-right(n)
        call 'emitbyte' using opLT
    when 'Greater'
        call 'codegen' using node-left(n)
        call 'codegen' using node-right(n)
        call 'emitbyte' using opGT
    when 'LessEqual'
        call 'codegen' using node-left(n)
        call 'codegen' using node-right(n)
        call 'emitbyte' using opLE
    when 'GreaterEqual'
        call 'codegen' using node-left(n)
        call 'codegen' using node-right(n)
        call 'emitbyte' using opGE
    when 'Equal'
        call 'codegen' using node-left(n)
        call 'codegen' using node-right(n)
        call 'emitbyte' using opEQ
    when 'NotEqual'
        call 'codegen' using node-left(n)
        call 'codegen' using node-right(n)
        call 'emitbyte' using opNE
    when 'And'
        call 'codegen' using node-left(n)
        call 'codegen' using node-right(n)
        call 'emitbyte' using opAND
    when 'Or'
        call 'codegen' using node-left(n)
        call 'codegen' using node-right(n)
        call 'emitbyte' using opOR
    when 'Subtract'
        call 'codegen' using node-left(n)
        call 'codegen' using node-right(n)
        call 'emitbyte' using opSUB
    when 'Add'
        call 'codegen' using node-left(n)
        call 'codegen' using node-right(n)
        call 'emitbyte' using opADD
    when 'Divide'
        call 'codegen' using node-left(n)
        call 'codegen' using node-right(n)
        call 'emitbyte' using opDIV
    when 'Multiply'
        call 'codegen' using node-left(n)
        call 'codegen' using node-right(n)
        call 'emitbyte' using opMUL
    when 'Mod'
        call 'codegen' using node-left(n)
        call 'codegen' using node-right(n)
        call 'emitbyte' using opMOD
    when 'Negate'
       call 'codegen' using node-left(n)
       call 'emitbyte' using opNEG
    when 'Not'
        call 'codegen' using node-left(n)
        call 'emitbyte' using opNOT
    when other
        string 'in generator unknown node type: ' node-type(n) into error-record
        call 'reporterror'
    end-evaluate
    .
end program codegen.

identification division.
program-id. variableoffset common.
data division.
linkage section.
01  variable-value pic x(48).
procedure division using variable-value.
start-variableoffset.
    perform varying v from 1 by 1
    until v > v-max
    or variable-entry(v) = variable-value
        continue
    end-perform
    if v > v-lim
        string 'in generator variable offset v exceeds ' v-lim into error-record
        call 'reporterror'
    end-if
    if v > v-max
        move v to v-max
        move variable-value to variable-entry(v)
    end-if
    .
end program variableoffset.

identification division.
program-id. stringoffset common.
data division.
linkage section.
01  string-value pic x(48).
procedure division using string-value.
start-stringoffset.
    perform varying s from 1 by 1
    until s > s-max
    or string-entry(s) = string-value
        continue
    end-perform
    if s > s-lim
        string ' generator stringoffset s exceeds ' s-lim into error-record
        call 'reporterror'
    end-if
    if s > s-max
        move s to s-max
        move string-value to string-entry(s)
    end-if
    subtract 1 from s *> convert index to offset
    .
end program stringoffset.

identification division.
program-id. emitbyte common.
data division.
linkage section.
01  opcode pic x.
procedure division using opcode.
start-emitbyte.
    if c >= c-lim
        string 'in generator emitbyte c exceeds ' c-lim into error-record
        call 'reporterror'
    end-if
    move opcode to kode(c:1)
    add 1 to c
    .
end program emitbyte.

identification division.
program-id. emitword common.
data division.
working-storage section.
01  word-x.
    03  word usage binary-int.
01  loc pic 999.
linkage section.
01  word-value any length.
01  loc-value any length.
procedure division using word-value loc-value.
start-emitword.
    if c + length(word) > c-lim
        string 'in generator emitword exceeds ' c-lim into error-record
        call 'reporterror'
    end-if
    move numval(word-value) to word
    move numval(loc-value) to loc
    if loc = 0
        move word-x to kode(c:length(word))
        add length(word) to c
    else
        move word-x to kode(loc:length(word))
    end-if
    .
end program emitword.

identification division.
program-id. listcode common.
data division.
working-storage section.
01  word-x.
    03  word usage binary-int.
01  address-display pic ---9.
01  address-absolute pic zzz9.
01  data-display pic -(9)9.
01  v-display pic z9.
01  s-display pic z9.
01  c-display pic zzz9.
procedure division.
start-listcode.
    move v-max to v-display
    move s-max to s-display
    display 'Datasize: ' trim(v-display) space 'Strings: ' trim(s-display)

    perform varying s from 1 by 1
    until s > s-max
        display string-entry(s)
    end-perform

    move 1 to c1
    perform until c1 >= c
        compute c-display = c1 - 1
        display c-display space with no advancing
        evaluate kode(c1:1)
        when opFETCH
            add 1 to c1
            move kode(c1:4) to word-x
            compute address-display = word - 1
            display 'fetch [' trim(address-display) ']'
            add 3 to c1
        when opSTORE
            add 1 to c1
            move kode(c1:4) to word-x
            compute address-display = word - 1
            display 'store [' trim(address-display) ']'
            add 3 to c1
        when opPUSH
            add 1 to c1
            move kode(c1:4) to word-x
            move word to data-display
            display 'push  ' trim(data-display)
            add 3 to c1
        when opADD   display 'add'
        when opSUB   display 'sub'
        when opMUL   display 'mul'
        when opDIV   display 'div'
        when opMOD   display 'mod'
        when opLT    display 'lt'
        when opGT    display 'gt'
        when opLE    display 'le'
        when opGE    display 'ge'
        when opEQ    display 'eq'
        when opNE    display 'ne'
        when opAND   display 'and'
        when opOR    display 'or'
        when opNEG   display 'neg'
        when opNOT   display 'not'
        when opJMP
            move kode(c1 + 1:length(word)) to word-x
            move word to address-display
            compute address-absolute = c1 + word
            display 'jmp    (' trim(address-display) ') ' trim(address-absolute)
            add length(word) to c1
        when opJZ
            move kode(c1 + 1:length(word)) to word-x
            move word to address-display
            compute address-absolute = c1 + word
            display 'jz     (' trim(address-display) ') ' trim(address-absolute)
            add length(word) to c1
        when opPRTC  display 'prtc'
        when opPRTI  display 'prti'
        when opPRTS  display 'prts'
        when opHALT  display 'halt'
        when other
            string 'in generator unknown opcode ' kode(c1:1) into error-record
            call 'reporterror'
        end-evaluate
        add 1 to c1
    end-perform
    .
end program listcode.

identification division.
program-id. loadast common recursive.
procedure division.
start-loadast.
    if l >= l-lim
        string 'in generator loadast l exceeds ' l-lim into error-record
        call 'reporterror'
    end-if
    add 1 to l
    call 'readinput'
    evaluate true
    when ast-record = ';'
    when input-status = '10'
        move 0 to return-code
    when ast-type = 'Identifier'
    when ast-type = 'Integer'
    when ast-type = 'String'
        call 'makeleaf' using ast-type ast-value
        move t to return-code
    when ast-type = 'Sequence'
        move ast-type to l-node(l)
        call 'loadast'
        move return-code to l-left(l)
        call 'loadast'
        move t to l-right(l)
        call 'makenode' using l-node(l) l-left(l) l-right(l)
        move t to return-code
    when other
        move ast-type to l-node(l)
        call 'loadast'
        move return-code to l-left(l)
        call 'loadast'
        move return-code to l-right(l)
        call 'makenode' using l-node(l) l-left(l) l-right(l)
        move t to return-code
    end-evaluate
    subtract 1 from l
    .
end program loadast.

identification division.
program-id. printast common recursive.
data division.
linkage section.
01  n pic 999.
procedure division using n.
start-printast.
    if n = 0
        display ';' upon syserr
        exit program
    end-if
    display leaf-type(n) upon syserr
    evaluate leaf-type(n)
    when 'Identifier'
    when 'Integer'
    when 'String'
        display leaf-type(n) space trim(leaf-value(n)) upon syserr
    when other
        display node-type(n) upon syserr
        call 'printast' using node-left(n)
        call 'printast' using node-right(n)
    end-evaluate
    .
end program printast.

identification division.
program-id. makenode common.
data division.
linkage section.
01  parm-type any length.
01  parm-l-left pic 999.
01  parm-l-right pic 999.
procedure division using parm-type parm-l-left parm-l-right.
start-makenode.
    if t >= t-lim
        string 'in generator makenode t exceeds ' t-lim into error-record
        call 'reporterror'
    end-if
    add 1 to t
    move parm-type to node-type(t)
    move parm-l-left to node-left(t)
    move parm-l-right to node-right(t)
    .
end program makenode.

identification division.
program-id. makeleaf common.
data division.
linkage section.
01  parm-type any length.
01  parm-value pic x(48).
procedure division using parm-type parm-value.
start-makeleaf.
    add 1 to t
    if t >= t-lim
        string 'in generator makeleaf t exceeds ' t-lim into error-record
        call 'reporterror'
    end-if
    move parm-type to leaf-type(t)
    move parm-value to leaf-value(t)
    .
end program makeleaf.

identification division.
program-id. readinput common.
environment division.
input-output section.
file-control.
    select input-file assign using input-name
        status is input-status
        organization is line sequential.
data division.
file section.
fd  input-file.
01  input-record pic x(64).
procedure division.
start-readinput.
    if program-name = spaces
        move '00' to input-status
        accept ast-record on exception move '10' to input-status end-accept
        exit program
    end-if
    if input-name = spaces
        string program-name delimited by space '.ast' into input-name
        open input input-file
        if input-status = '35'
            string 'in generator ' trim(input-name) ' not found' into error-record
            call 'reporterror'
        end-if
    end-if
    read input-file into ast-record
    evaluate input-status
    when '00'
        continue
    when '10'
        close input-file
    when other
        string 'in generator ' trim(input-name) ' unexpected input-status: ' input-status
            into error-record
        call 'reporterror'
    end-evaluate
    .
end program readinput.

program-id. reporterror common.
procedure division.
start-reporterror.
report-error.
    display error-record upon syserr
    stop run with error status -1
    .
end program reporterror.

identification division.
program-id. showhex common.

data division.
working-storage section.
01  hex.
    03  filler pic x(32) value '000102030405060708090A0B0C0D0E0F'.
    03  filler pic x(32) value '101112131415161718191A1B1C1D1E1F'.
    03  filler pic x(32) value '202122232425262728292A2B2C2D2E2F'.
    03  filler pic x(32) value '303132333435363738393A3B3C3D3E3F'.
    03  filler pic x(32) value '404142434445464748494A4B4C4D4E4F'.
    03  filler pic x(32) value '505152535455565758595A5B5C5D5E5F'.
    03  filler pic x(32) value '606162636465666768696A6B6C6D6E6F'.
    03  filler pic x(32) value '707172737475767778797A7B7C7D7E7F'.
    03  filler pic x(32) value '808182838485868788898A8B8C8D8E8F'.
    03  filler pic x(32) value '909192939495969798999A9B9C9D9E9F'.
    03  filler pic x(32) value 'A0A1A2A3A4A5A6A7A8A9AAABACADAEAF'.
    03  filler pic x(32) value 'B0B1B2B3B4B5B6B7B8B9BABBBCBDBEBF'.
    03  filler pic x(32) value 'C0C1C2C3C4C5C6C7C8C9CACBCCCDCECF'.
    03  filler pic x(32) value 'D0D1D2D3D4D5D6D7D8D9DADBDCDDDEDF'.
    03  filler pic x(32) value 'E0E1E2E3E4E5E6E7E8E9EAEBECEDEEEF'.
    03  filler pic x(32) value 'F0F1F2F3F4F5F6F7F8F9FAFBFCFDFEFF'.

01  cdx pic 9999.
01  bdx pic 999.
01  byte-count pic 9.
01  bytes-per-word pic 9 value 4.
01  word-count pic 9.
01  words-per-line pic 9 value 8.

linkage section.
01  data-field any length.
01  length-data-field pic 999.

procedure division using
    by reference data-field
    by reference length-data-field.
start-showhex.
    move 1 to byte-count
    move 1 to word-count
    perform varying cdx from 1 by 1
    until cdx > length-data-field
         compute bdx = 2 * ord(data-field(cdx:1)) - 1 end-compute
         display hex(bdx:2) with no advancing upon syserr
         add 1 to byte-count end-add
         if byte-count > bytes-per-word
             display ' ' with no advancing upon syserr
             move 1 to byte-count
             add 1 to word-count end-add
         end-if
         if word-count > words-per-line
             display ' ' upon syserr
             move 1 to word-count
         end-if
    end-perform
    if word-count <> 1
    or byte-count <> 1
        display ' ' upon syserr
    end-if
    display ' ' upon syserr
    goback
    .
end program showhex.
end program generator.


begin % syntax analyser %
    % parse tree nodes %
    record node( integer         type
               ; reference(node) left, right
               ; integer         iValue % nString/nIndentifier number or nInteger value %
               );
    integer     nIdentifier, nString, nInteger, nSequence, nIf,   nPrtc, nPrts
          ,     nPrti,       nWhile,  nAssign,  nNegate,   nNot,  nMultiply
          ,     nDivide,     nMod,    nAdd,     nSubtract, nLess, nLessEqual
          ,     nGreater,    nGreaterEqual,     nEqual,    nNotEqual,    nAnd, nOr
          ;
    string(14) array ndName ( 1 :: 25 );
    % tokens - names must match those output by the lexical analyser %
    integer     tkType, tkLine, tkColumn, tkLength, tkIntegerValue;
    integer     tOp_multiply   , tOp_divide        , tOp_mod       , tOp_add
          ,     tOp_subtract   , tOp_negate        , tOp_less      , tOp_lessequal
          ,     tOp_greater    , tOp_greaterequal  , tOp_equal     , tOp_notequal
          ,     tOp_not        , tOp_assign        , tOp_and       , tOp_or
          ,     tLeftParen     , tRightParen       , tLeftBrace    , tRightBrace
          ,     tSemicolon     , tComma            , tKeyword_if   , tKeyword_else
          ,     tKeyword_while , tKeyword_print    , tKeyword_putc , tIdentifier
          ,     tInteger       , tString           , tEnd_of_input
          ,     MAX_TOKEN_TYPE, PRIMARY_PREC
          ;
    string(16)  array tkName         ( 1 :: 31 );
    integer     array tkPrec, tkNode ( 1 :: 31 );
    % string literals and identifiers - uses a linked list - a hash table might be better... %
    string(1)   array text ( 0 :: 4095 );
    integer     textNext, TEXT_MAX;
    record textElement ( integer start, length; reference(textElement) next );
    reference(textElement) idList, stList;

    % returns a new node with left and right branches %
    reference(node) procedure opNode ( integer value opType; reference(node) value opLeft, opRight ) ; begin
        node( opType, opLeft, opRight, 0 )
    end opNode ;

    % returns a new operand node %
    reference(node) procedure operandNode ( integer value opType, opValue ) ; begin
        node( opType, null, null, opValue )
    end operandNode ;

    % reports an error %
    procedure synError( integer value line, column; string(80) value message ); begin
        integer errorPos;
        write( i_w := 1, s_w := 0, "**** Error at(", line, ",", column, "): " );
        errorPos := 0;
        while errorPos < 80 and message( errorPos // 1 ) not = "." do begin
            writeon( s_w := 0, message( errorPos // 1 ) );
            errorPos := errorPos + 1
        end while_not_at_end_of_message ;
        writeon( s_w := 0, "." )
    end synError ;

    % reports an error and stops %
    procedure fatalError( integer value line, column; string(80) value message ); begin
        synError( line, column, message );
        assert( false )
    end fatalError ;

    % prints a node and its sub-nodes %
    procedure writeNode( reference(node) value n ) ; begin
        % prints an identifier or string from text %
        procedure writeOnText( reference(textElement) value txHead; integer value txNumber ) ;
        begin
            reference(textElement) txPos;
            integer                count;
            txPos := txHead;
            count := 1;
            while count < txNumber and txPos not = null do begin
                txPos := next(txPos);
                count := count + 1
            end while_text_element_not_found ;
            if txPos = null then fatalError( 0, txNumber, "INTERNAL ERROR: text not found." )
            else for cPos := 0 until length(txPos) - 1 do writeon( text( start(txPos) + cPos ) );
            if text( start(txPos) ) = """" then writeon( """" );
        end writeOnText ;

        if n = null then write( ";" )
        else begin
            write( ndName( type(n) ) );
            if      type(n) = nInteger    then writeon( iValue(n) )
            else if type(n) = nIdentifier then writeOnText( idList, iValue(n) )
            else if type(n) = nString     then writeOnText( stList, iValue(n) )
            else begin
                writeNode(  left(n) );
                writeNode( right(n) )
            end
        end
    end writeNode ;

    % reads a token from standard input %
    procedure readToken ; begin

        % parses a string from line and stores it in a string in the text array %
        % - if it is not already present in the specified textElement list.     %
        % returns the position of the string in the text array                  %
        integer procedure readString ( reference(textElement) value result txList; string(1) value terminator ) ; begin
            string(256) str;
            integer     sLen, sPos, ePos;
            logical     found;
            reference(textElement) txPos, txLastPos;
            % get the text of the string %
            str  := " ";
            sLen := 0;
            str( sLen // 1 ) := line( lPos // 1 );
            sLen := sLen + 1;
            lPos := lPos + 1;
            while lPos <= 255 and line( lPos // 1 ) not = terminator do begin
                str( sLen // 1 ) := line( lPos // 1 );
                sLen := sLen + 1;
                lPos := lPos + 1
            end while_more_string ;
            if lPos > 255 then fatalError( tkLine, tkColumn, "Unterminated String in token file." );
            % attempt to find the text in the list of strings/identifiers %
            txLastPos := txPos := txList;
            found := false;
            ePos := 0;
            while not found and txPos not = null do begin
                ePos  := ePos + 1;
                found := ( length(txPos) = sLen );
                sPos  := 0;
                while found and sPos < sLen do begin
                    found := str( sPos // 1 ) = text( start(txPos) + sPos );
                    sPos  := sPos + 1
                end while_not_found ;
                txLastPos := txPos;
                if not found then txPos := next(txPos)
            end while_string_not_found ;
            if not found then begin
                % the string/identifier is not in the list - add it %
                ePos := ePos + 1;
                if txList = null then txList := textElement( textNext, sLen, null )
                                 else next(txLastPos) := textElement( textNext, sLen, null );
                if textNext + sLen > TEXT_MAX then fatalError( tkLine, tkColumn, "Text space exhausted." )
                else begin
                    for cPos := 0 until sLen - 1 do begin
                        text( textNext ) := str( cPos // 1 );
                        textNext := textNext + 1
                    end for_cPos
                end
            end if_not_found ;
            ePos
        end readString ;

        % gets an integer from the line - no checks for valid digits %
        integer procedure readInteger ; begin
            integer n;
            while line( lPos // 1 ) = " " do lPos := lPos + 1;
            n := 0;
            while line( lPos // 1 ) not = " " do begin
                n    := ( n * 10 ) + ( decode( line( lPos // 1 ) ) - decode( "0" ) );
                lPos := lPos + 1
            end while_not_end_of_integer ;
            n
        end readInteger ;

        string(256) line;
        string(16)  name;
        integer     lPos, tPos;
        tPos := lPos := 0;
        readcard( line );
        % get the line and column numbers %
        tkLine   := readInteger;
        tkColumn := readInteger;
        % get the token name %
        while line( lPos // 1 ) = " " do lPos := lPos + 1;
        name := "";
        while lPos < 256 and line( lPos // 1 ) not = " " do begin
            name( tPos // 1 ) := line( lPos // 1 );
            lPos := lPos + 1;
            tPos := tPos + 1
        end  while_more_name ;
        % determine the token type %
        tkType         := 1;
        tkIntegerValue := 0;
        while tkType <= MAX_TOKEN_TYPE and name not = tkName( tkType ) do tkType := tkType + 1;
        if tkType > MAX_TOKEN_TYPE then fatalError( tkLine, tkColumn, "Malformed token" );
        % handle the additional parameter for identifier/string/integer %
        if tkType = tInteger or tkType = tIdentifier or tkType = tString then begin
            while line( lPos // 1 ) = " " do lPos := lPos + 1;
            if      tkType = tInteger    then tkIntegerValue := readInteger
            else if tkType = tIdentifier then tkIntegerValue := readString( idList, " "  )
            else  % tkType = tString     %    tkIntegerValue := readString( stList, """" )
        end if_token_with_additional_parameter ;
    end readToken ;

    % parses a statement %
    reference(node) procedure parseStatement ; begin
        reference(node) stmtNode, stmtExpr;

        % skips the current token if it is expectedToken,              %
        % returns true if the token was expectedToken, false otherwise %
        logical procedure have ( integer value expectedToken ) ; begin
            logical haveExpectedToken;
            haveExpectedToken := ( tkType = expectedToken );
            if haveExpectedToken and tkType not = tEnd_of_input then readToken;
            haveExpectedToken
        end have ;

        % issues an error message and skips past the next semi-colon or to end of input %
        procedure skipStatement ( string(80) value message ) ; begin
            synError( tkLine, tkColumn, message );
            while tkType not = tEnd_of_input and not have( tSemicolon ) do readToken
        end skipStatement ;

        % checks we have a semicolon, issues an error and skips the statement if not %
        procedure mustBeEndOfStatement ; begin
            if not have( tSemicolon ) then skipStatement( """;"" expected." )
        end mustBeEndOfStatement ;

        % skips the current token if it is "(" and issues an error if it isn't %
        procedure mustBeLeftParen ; begin
            if not have( tLeftParen ) then synError( tkLine, tkColumn, """("" expected." )
        end % mustBeLeftParen % ;

        % skips the current token if it is ")" and issues an error if it isn't %
        procedure mustBeRightParen ; begin
            if not have( tRightParen ) then synError( tkLine, tkColumn, """)"" expected." )
        end % mustBeRightParen % ;

        % gets the next token and parses an expression with the specified precedence %
        reference(node) procedure nextAndparseExpr ( integer value precedence ) ; begin
            readToken;
            parseExpr( precedence )
        end nextAndParseExpr ;

        % parses an expression with the specified precedence %
        % all operators are assumed to be left-associative %
        reference(node) procedure parseExpr ( integer value precedence ) ; begin

            % handles a single token primary %
            reference(node) procedure simplePrimary ( integer value primaryNodeType ) ; begin
                reference(node) primaryNode;
                primaryNode := operandNode( primaryNodeType, tkIntegerValue );
                readToken;
                primaryNode
            end simplePrimary ;

            reference(node) exprNode;

            if precedence < PRIMARY_PREC  then begin
                exprNode := parseExpr( precedence + 1 );
                while tkPrec( tkType ) = precedence do begin
                    integer op;
                    op := tkNode( tkType );
                    exprNode := opNode( op, exprNode, nextAndParseExpr( precedence + 1 ) )
                end while_op_at_this_precedence_level
                end
            else if tkType = tIdentifier  then exprNode := simplePrimary( nIdentifier )
            else if tkType = tInteger     then exprNode := simplePrimary( nInteger    )
            else if tkType = nString      then begin
                synError( tkLine, tkColumn, "Unexpected string literal." );
                exprNode := simplePrimary( nInteger )
                end
            else if tkType = tLeftParen   then exprNode := parseParenExpr
            else if tkType = tOp_add      then exprNode := nextAndParseExpr( precedence )
            else if tkType = tOp_subtract then exprNode := opNode( nNegate, nextAndParseExpr( precedence ), null )
            else if tkType = tOp_not      then exprNode := opNode( nNot,    nextAndParseExpr( precedence ), null )
            else begin
                synError( tkLine, tkColumn, "Syntax error in expression." );
                exprNode := simplePrimary( nInteger )
            end;
            exprNode
        end parseExpr ;

        % parses a preenthesised expression %
        reference(node) procedure parseParenExpr ; begin
            reference(node) exprNode;
            mustBeLeftParen;
            exprNode := parseExpr( 0 );
            mustBeRightParen;
            exprNode
        end parseParenExpr ;

        % parse statement depending on it's first token %
        if      tkType = tIdentifier then begin % assignment statement %
            stmtExpr := operandNode( nIdentifier, tkIntegerValue );
            % skip the identifier and check for "=" %
            readToken;
            if not have( tOp_Assign ) then synError( tkLine, tkColumn, "Expected ""="" in assignment statement." );
            stmtNode := opNode( nAssign, stmtExpr, parseExpr( 0 ) );
            mustBeEndOfStatement
            end
        else if have( tKeyword_while ) then begin
            stmtExpr := parseParenExpr;
            stmtNode := opNode( nWhile, stmtExpr, parseStatement )
            end
        else if have( tkeyword_if ) then begin
            stmtExpr := parseParenExpr;
            stmtNode := opNode( nIf, stmtExpr, opNode( nIf, parseStatement, null ) );
            if have( tKeyword_else ) then % have an "else" part % right(right(stmtNode)) := parseStatement
            end
        else if have( tKeyword_Print ) then begin
            mustBeLeftParen;
            stmtNode := null;
            while begin
                if tkType = tString then begin
                    stmtNode  := opNode( nSequence, stmtNode, opNode( nPrts, operandNode( nString, tkIntegerValue ), null ) );
                    readToken
                    end
                else stmtNode := opNode( nSequence, stmtNode, opNode( nPrti, parseExpr( 0 ), null ) );
                have( tComma )
            end do begin end;
            mustBeRightparen;
            mustBeEndOfStatement;
            end
        else if have( tKeyword_Putc ) then begin
            stmtNode := opNode( nPrtc, parseParenExpr, null );
            mustBeEndOfStatement
            end
        else if have( tLeftBrace ) then begin % block %
            stmtNode := parseStatementList( tRightBrace );
            if not have( tRightBrace ) then synError( tkLine, tkColumn, "Expected ""}""." );
            end
        else if have( tSemicolon ) then stmtNode := null
        else begin % unrecognised statement %
            skipStatement( "Unrecognised statement." );
            stmtNode := null
        end if_various_tokens ;
        stmtNode
    end parseStatement ;

    % parses a statement list ending with the specified terminator %
    reference(node) procedure parseStatementList ( integer value terminator ) ; begin
        reference(node) listNode;
        listNode := null;
        while tkType not = terminator and tkType not = tEnd_of_input do listNode := opNode( nSequence, listNode, parseStatement );
        listNode
    end parseStatementList ;

    nIdentifier      :=  1; ndName( nIdentifier      ) := "Identifier";   nString    :=  2; ndName( nString   ) := "String";
    nInteger         :=  3; ndName( nInteger         ) := "Integer";      nSequence  :=  4; ndName( nSequence ) := "Sequence";
    nIf              :=  5; ndName( nIf              ) := "If";           nPrtc      :=  6; ndName( nPrtc     ) := "Prtc";
    nPrts            :=  7; ndName( nPrts            ) := "Prts";         nPrti      :=  8; ndName( nPrti     ) := "Prti";
    nWhile           :=  9; ndName( nWhile           ) := "While";        nAssign    := 10; ndName( nAssign   ) := "Assign";
    nNegate          := 11; ndName( nNegate          ) := "Negate";       nNot       := 12; ndName( nNot      ) := "Not";
    nMultiply        := 13; ndName( nMultiply        ) := "Multiply";     nDivide    := 14; ndName( nDivide   ) := "Divide";
    nMod             := 15; ndName( nMod             ) := "Mod";          nAdd       := 16; ndName( nAdd      ) := "Add";
    nSubtract        := 17; ndName( nSubtract        ) := "Subtract";     nLess      := 18; ndName( nLess     ) := "Less";
    nLessEqual       := 19; ndName( nLessEqual       ) := "LessEqual"  ;  nGreater   := 20; ndName( nGreater  ) := "Greater";
    nGreaterEqual    := 21; ndName( nGreaterEqual    ) := "GreaterEqual"; nEqual     := 22; ndName( nEqual    ) := "Equal";
    nNotEqual        := 23; ndName( nNotEqual        ) := "NotEqual";     nAnd       := 24; ndName( nAnd      ) := "And";
    nOr              := 25; ndName( nOr              ) := "Or";
    tOp_multiply     :=  1; tkName( tOp_multiply     ) := "Op_multiply";     tkPrec( tOp_multiply     ) :=  5;
    tOp_divide       :=  2; tkName( tOp_divide       ) := "Op_divide";       tkPrec( tOp_divide       ) :=  5;
    tOp_mod          :=  3; tkName( tOp_mod          ) := "Op_mod";          tkPrec( tOp_mod          ) :=  5;
    tOp_add          :=  4; tkName( tOp_add          ) := "Op_add";          tkPrec( tOp_add          ) :=  4;
    tOp_subtract     :=  5; tkName( tOp_subtract     ) := "Op_subtract";     tkPrec( tOp_subtract     ) :=  4;
    tOp_negate       :=  6; tkName( tOp_negate       ) := "Op_negate";       tkPrec( tOp_negate       ) := -1;
    tOp_less         :=  7; tkName( tOp_less         ) := "Op_less";         tkPrec( tOp_less         ) :=  3;
    tOp_lessequal    :=  8; tkName( tOp_lessequal    ) := "Op_lessequal";    tkPrec( tOp_lessequal    ) :=  3;
    tOp_greater      :=  9; tkName( tOp_greater      ) := "Op_greater";      tkPrec( tOp_greater      ) :=  3;
    tOp_greaterequal := 10; tkName( tOp_greaterequal ) := "Op_greaterequal"; tkPrec( tOp_greaterequal ) :=  3;
    tOp_equal        := 11; tkName( tOp_equal        ) := "Op_equal";        tkPrec( tOp_equal        ) :=  2;
    tOp_notequal     := 12; tkName( tOp_notequal     ) := "Op_notequal";     tkPrec( tOp_notequal     ) :=  2;
    tOp_not          := 13; tkName( tOp_not          ) := "Op_not";          tkPrec( tOp_not          ) := -1;
    tOp_assign       := 14; tkName( tOp_assign       ) := "Op_assign";       tkPrec( tOp_assign       ) := -1;
    tOp_and          := 15; tkName( tOp_and          ) := "Op_and";          tkPrec( tOp_and          ) :=  1;
    tOp_or           := 16; tkName( tOp_or           ) := "Op_or";           tkPrec( tOp_or           ) :=  0;
    tLeftParen       := 17; tkName( tLeftParen       ) := "LeftParen";       tkPrec( tLeftParen       ) := -1;
    tRightParen      := 18; tkName( tRightParen      ) := "RightParen";      tkPrec( tRightParen      ) := -1;
    tLeftBrace       := 19; tkName( tLeftBrace       ) := "LeftBrace";       tkPrec( tLeftBrace       ) := -1;
    tRightBrace      := 20; tkName( tRightBrace      ) := "RightBrace";      tkPrec( tRightBrace      ) := -1;
    tSemicolon       := 21; tkName( tSemicolon       ) := "Semicolon";       tkPrec( tSemicolon       ) := -1;
    tComma           := 22; tkName( tComma           ) := "Comma";           tkPrec( tComma           ) := -1;
    tKeyword_if      := 23; tkName( tKeyword_if      ) := "Keyword_if";      tkPrec( tKeyword_if      ) := -1;
    tKeyword_else    := 24; tkName( tKeyword_else    ) := "Keyword_else";    tkPrec( tKeyword_else    ) := -1;
    tKeyword_while   := 25; tkName( tKeyword_while   ) := "Keyword_while";   tkPrec( tKeyword_while   ) := -1;
    tKeyword_print   := 26; tkName( tKeyword_print   ) := "Keyword_print";   tkPrec( tKeyword_print   ) := -1;
    tKeyword_putc    := 27; tkName( tKeyword_putc    ) := "Keyword_putc";    tkPrec( tKeyword_putc    ) := -1;
    tIdentifier      := 28; tkName( tIdentifier      ) := "Identifier";      tkPrec( tIdentifier      ) := -1;
    tInteger         := 29; tkName( tInteger         ) := "Integer";         tkPrec( tInteger         ) := -1;
    tString          := 30; tkName( tString          ) := "String";          tkPrec( tString          ) := -1;
    tEnd_of_input    := 31; tkName( tEnd_of_input    ) := "End_of_input";    tkPrec( tEnd_of_input    ) := -1;
    MAX_TOKEN_TYPE   := 31; TEXT_MAX := 4095; textNext := 0; PRIMARY_PREC := 6;
    for tkPos := 1 until MAX_TOKEN_TYPE do tkNode( tkPos ) := - tkPos;
    tkNode( tOp_multiply     ) := nMultiply;  tkNode( tOp_divide   ) := nDivide;   tkNode( tOp_mod          ) := nMod;
    tkNode( tOp_add          ) := nAdd;       tkNode( tOp_subtract ) := nSubtract; tkNode( tOp_less         ) := nLess;
    tkNode( tOp_lessequal    ) := nLessEqual; tkNode( tOp_greater  ) := nGreater;  tkNode( tOp_greaterequal ) := nGreaterEqual;
    tkNode( tOp_equal        ) := nEqual;     tkNode( tOp_notequal ) := nNotEqual; tkNode( tOp_not          ) := nNot;
    tkNode( tOp_and          ) := nAnd;       tkNode( tOp_or       ) := nOr;
    stList := idList := null;

    % parse the output from the lexical analyser and output the linearised parse tree %
    readToken;
    writeNode( parseStatementList( tEnd_of_input ) )
end.


my @CODE = q:to/END/.lines;
Datasize: 3 Strings: 2
"count is: "
"\n"
    0 push  1
    5 store [0]
   10 fetch [0]
   15 push  10
   20 lt
   21 jz     (68) 65    # jump value adjusted
   26 push  0
   31 prts
   32 fetch [0]
   37 prti
   38 push  1
   43 prts
   44 fetch [0]
   49 push  1
   54 add
   55 store [0]
   60 jmp    (-87) 10   # jump value adjusted
   65 halt
END

my (@stack, @strings, @data, $memory);
my $pc = 0;

(@CODE.shift) ~~ /'Datasize:' \s+ (\d+) \s+ 'Strings:' \s+ (\d+)/ or die "bad header";
my $w = $0; # 'wordsize' of op-codes and 'width' of data values
@strings.push: (my $s = @CODE.shift) eq '"\n"' ?? "\n" !! $s.subst(/'"'/, '', :g) for 1..$1;

sub value { substr($memory, ($pc += $w) - $w, $w).trim }

my %ops = (
  'no-op' => sub { },
  'add'   => sub { @stack[*-2]  +=   @stack.pop },
  'sub'   => sub { @stack[*-2]  -=   @stack.pop },
  'mul'   => sub { @stack[*-2]  *=   @stack.pop },
  'div'   => sub { @stack[*-2]  /=   @stack.pop },
  'mod'   => sub { @stack[*-2]  %=   @stack.pop },
  'neg'   => sub { @stack[*-1]   = - @stack[*-1] },
  'and'   => sub { @stack[*-2] &&=   @stack[*-1]; @stack.pop },
  'or'    => sub { @stack[*-2] ||=   @stack[*-1]; @stack.pop },
  'not'   => sub { @stack[*-1]   =   @stack[*-1]               ?? 0 !! 1 },
  'lt'    => sub { @stack[*-1]   =   @stack[*-2] <  @stack.pop ?? 1 !! 0 },
  'gt'    => sub { @stack[*-1]   =   @stack[*-2] >  @stack.pop ?? 1 !! 0 },
  'le'    => sub { @stack[*-1]   =   @stack[*-2] <= @stack.pop ?? 1 !! 0 },
  'ge'    => sub { @stack[*-1]   =   @stack[*-2] >= @stack.pop ?? 1 !! 0 },
  'ne'    => sub { @stack[*-1]   =   @stack[*-2] != @stack.pop ?? 1 !! 0 },
  'eq'    => sub { @stack[*-1]   =   @stack[*-2] == @stack.pop ?? 1 !! 0 },
  'store' => sub { @data[&value] =   @stack.pop },
  'fetch' => sub { @stack.push:      @data[&value] // 0 },
  'push'  => sub { @stack.push:      value() },
  'jmp'   => sub { $pc += value() - $w },
  'jz'    => sub { $pc += @stack.pop ?? $w !! value() - $w },
  'prts'  => sub { print @strings[@stack.pop] },
  'prti'  => sub { print @stack.pop },
  'prtc'  => sub { print chr @stack.pop },
  'halt'  => sub { exit }
);

my %op2n = %ops.keys.sort Z=> 0..*;
my %n2op = %op2n.invert;
%n2op{''} = 'no-op';

for @CODE -> $_ {
    next unless /\w/;
    /^ \s* \d+ \s+ (\w+)/ or die "bad line $_";
    $memory ~= %op2n{$0}.fmt("%{$w}d");
    /'(' ('-'?\d+) ')' | (\d+) ']'? $/;
    $memory ~= $0 ?? $0.fmt("%{$w}d") !! ' ' x $w;
}

loop {
    my $opcode = substr($memory, $pc, $w).trim;
    $pc += $w;
    %ops{%n2op{ $opcode }}();
}


import re
import strutils

let r = re"(\.[0-9]+|[1-9]([0-9]+)?(\.[0-9]+)?)"

#---------------------------------------------------------------------------------------------------

proc commatize(str: string; startIndex = 0; period = 3; sep = ","): string =

  result = str
  var dp, ip = ""

  if startIndex notin 0..str.high : return

  # Extract first number (if any).
  let (lowBound, highBound) = str.findBounds(r, startIndex)
  if lowBound < 0: return
  let match = str[lowBound..highBound]
  let splits = match.split('.')

  # Process integer part.
  ip = splits[0]
  if ip.len > period:
    var inserted = 0
    for i in countup(ip.high mod period + 1, ip.high, period):
      ip.insert(sep, i + inserted)
      inserted += sep.len

  # Process decimal part.
  if '.' in match:
    dp = splits[1]
    if dp.len > period:
      for i in countdown(dp.high div period * period, period, period):
        dp.insert(sep, i)
    ip &= '.' & dp

  # Replace the number by its "commatized" version.
  result[lowBound..highBound] = ip

#———————————————————————————————————————————————————————————————————————————————————————————————————

const Tests = [
      "123456789.123456789",
      ".123456789",
      "57256.1D-4",
      "pi=3.14159265358979323846264338327950288419716939937510582097494459231",
      "The author has two Z$100000000000000 Zimbabwe notes (100 trillion).",
      "-in Aus$+1411.8millions",
      "===US$0017440 millions=== (in 2000 dollars)",
      "123.e8000 is pretty big.",
      "The land area of the earth is 57268900(29% of the surface) square miles.",
      "Ain't no numbers in this here words, nohow, no way, Jose.",
      "James was never known as 0000000007",
      "Arthur Eddington wrote: I believe there are " &
        "15747724136275002577605653961181555468044717914527116709366231425076185631031296" &
        " protons in the universe.",
      "   $-140000±100 millions.",
      "6/9/1946 was a good year for some."]

echo Tests[0].commatize(period = 2, sep = "*")
echo Tests[1].commatize(period = 3, sep = "-")
echo Tests[2].commatize(period = 4, sep = "__")
echo Tests[3].commatize(period = 5, sep = " ")
echo Tests[4].commatize(sep = ".")

for n in 5..Tests.high:
  echo Tests[n].commatize()


@input = (
    ['pi=3.14159265358979323846264338327950288419716939937510582097494459231', ' ', 5],
    ['The author has two Z$100000000000000 Zimbabwe notes (100 trillion).', '.'],
    ['-in Aus$+1411.8millions'],
    ['===US$0017440 millions=== (in 2000 dollars)'],
    ['123.e8000 is pretty big.'],
    ['The land area of the earth is  57268900(29% of the surface)  square miles.'],
    ['Ain\'t no numbers in this here words, nohow, no way, Jose.'],
    ['James was never known as  0000000007'],
    ['Arthur Eddington wrote: I believe there are 15747724136275002577605653961181555468044717914527116709366231425076185631031296 protons in the universe.'],
    ['   $-140000±100  millions.'],
    ['5/9/1946 was a good year for some.']
);

for $i (@input) {
    $old = @$i[0];
    $new = commatize(@$i);
    printf("%s\n%s\n\n", $old, $new) if $old ne $new;
}

sub commatize {
    my($str,$sep,$by) = @_;
    $sep = ',' unless $sep;
    $by  = 3   unless $by;

    $str =~ s/                      # matching rules:
            (?<![eE\/])             #   not following these characters
            ([1-9]\d{$by,})         #   leading non-zero digit, minimum number of digits required
            /c_ins($1,$by,$sep)/ex; # substitute matched text with subroutine output
    return $str;
}

sub c_ins {
    my($s,$by,$sep) = @_;
    ($c = reverse $s) =~ s/(.{$by})/$1$sep/g;
    $c =~ s/$sep$//;
    return reverse $c;
}


CREATE BUF 0 ,
: PEEK   BUF @ 0= IF KEY BUF ! THEN BUF @ ;
: GETC   PEEK  0 BUF ! ;
: SPACE?   DUP BL = SWAP 9 14 WITHIN OR ;
: >SPACE   BEGIN PEEK SPACE? WHILE GETC DROP REPEAT ;
: DIGIT?   48 58 WITHIN ;
: >Integer   >SPACE  0
   BEGIN  PEEK DIGIT?
   WHILE  GETC [CHAR] 0 -  SWAP 10 * +  REPEAT ;
: SKIP ( xt --)
   BEGIN PEEK OVER EXECUTE WHILE GETC DROP REPEAT DROP ;
: WORD ( xt -- c-addr)  DUP >R SKIP  PAD 1+
   BEGIN PEEK [email protected] EXECUTE INVERT
   WHILE GETC OVER C! CHAR+
   REPEAT  R> SKIP  PAD TUCK - 1-  PAD C! ;
: INTERN ( c-addr -- c-addr)
   HERE TUCK OVER [email protected] CHAR+ DUP ALLOT CMOVE ;
: "?   [CHAR] " = ;
: "TYPE"   [CHAR] " EMIT  TYPE  [CHAR] " EMIT ;
: .   0 .R ;
: [email protected] ( addr -- w3 w2 w1)
   [ 2 CELLS ]L + DUP @ SWAP CELL - DUP @ SWAP CELL - @ ;

CREATE BUF' 12 ALLOT
: PREPEND ( c-addr c -- c-addr)  BUF' 1+ C!
   COUNT 10 MIN DUP 1+ BUF' C!  BUF' 2 + SWAP CMOVE  BUF' ;
: >NODE ( c-addr -- n)   [CHAR] $ PREPEND  FIND
   IF EXECUTE ELSE ." unrecognized node " COUNT TYPE CR THEN ;
: NODE ( n left right -- addr)  HERE >R , , , R> ;

: CONS ( a b l -- l)  HERE >R , , , R> ;
: FIRST ( l -- a)  [ 2 CELLS ]L + @ ;
: SECOND ( l -- b)  CELL+ @ ;
: C=? ( c-addr1 c-addr2 -- t|f)  COUNT ROT COUNT COMPARE 0= ;
: LOOKUP ( c-addr l -- n t | c-addr f)
   BEGIN DUP WHILE OVER OVER FIRST C=?
     IF NIP SECOND TRUE EXIT THEN  @
   REPEAT  DROP FALSE ;

CREATE GLOBALS 0 ,  CREATE STRINGS 0 ,
: DEPTH ( pool -- n)  DUP IF SECOND 1+ THEN ;
: FISH ( c-addr pool -- n pool') TUCK LOOKUP  IF SWAP
   ELSE INTERN OVER DEPTH ROT OVER >R CONS  R> SWAP THEN ;
: >Identifier   ['] SPACE? WORD GLOBALS @ FISH GLOBALS ! ;
: >String       ['] "? WORD STRINGS @ FISH STRINGS ! ;
: >;   0 ;
: HANDLER   [CHAR] @ PREPEND  FIND DROP ;
: READER ( c-addr -- xt t | f)
   [CHAR] > PREPEND  FIND  DUP 0= IF NIP THEN ;
DEFER GETAST
: READ ( c-addr -- right left)  READER
   IF EXECUTE 0 ELSE GETAST GETAST THEN SWAP ;
: (GETAST)   ['] SPACE? WORD  DUP HANDLER >R  READ  R> NODE ;
' (GETAST) IS GETAST

CREATE PC 0 ,
: i32! ( n addr --)
   OVER           $FF AND OVER C! 1+
   OVER  8 RSHIFT $FF AND OVER C! 1+
   OVER 16 RSHIFT $FF AND OVER C! 1+
   OVER 24 RSHIFT $FF AND OVER C!    DROP DROP ;
: i32, ( n --)  HERE i32!  4 ALLOT  4 PC +! ;
: i8, ( c --)  C,  1 PC +! ;
: [email protected]+   DUP 1+ SWAP [email protected]  1 PC +! ;
: [email protected]+ ( addr -- addr+4 n)
   [email protected]+                 >R  [email protected]+  8 LSHIFT R> OR >R
   [email protected]+ 16 LSHIFT R> OR >R  [email protected]+ 24 LSHIFT R> OR ;

CREATE #OPS 0 ,
: OP:   CREATE #OPS @ ,  1 #OPS +!  DOES> @ ;
OP: fetch  OP: store  OP: push  OP: jmp  OP: jz
OP: prtc   OP: prti   OP: prts  OP: neg  OP: not
OP: add    OP: sub    OP: mul   OP: div  OP: mod
OP: lt     OP: gt     OP: le    OP: ge
OP: eq     OP: ne     OP: and   OP: or   OP: halt

: GEN ( ast --)  [email protected] EXECUTE ;
: @; ( r l)  DROP DROP ;
: @Identifier   fetch i8, i32, DROP ;
: @Integer    push i8, i32, DROP ;
: @String    push i8, i32, DROP ;
: @Prtc   GEN prtc i8, DROP ;
: @Prti   GEN prti i8, DROP ;
: @Prts   GEN prts i8, DROP ;
: @Not    GEN not i8, DROP ;
: @Negate   GEN neg i8, DROP ;
: @Sequence   GEN GEN ;
: @Assign   CELL+ @ >R GEN  store i8, R> i32, ;
: @While   PC @ SWAP  GEN  jz i8, HERE >R 0 i32,
   SWAP GEN  jmp i8, i32,  PC @ R> i32! ;
: @If   GEN  jz i8, HERE >R 0 i32,
   CELL+ DUP CELL+ @ DUP @ ['] @; = IF DROP @
   ELSE SWAP @ GEN  jmp i8, HERE 0 i32,  PC @ R> i32!  >R
   THEN  GEN PC @ R> i32! ;
: BINARY   >R GEN GEN R> i8, ;
: @Subtract   sub BINARY ;  : @Add            add BINARY ;
: @Mod        mod BINARY ;  : @Multiply       mul BINARY ;
: @Divide     div BINARY ;
: @Less       lt  BINARY ;  : @LessEqual      le  BINARY ;
: @Greater    gt  BINARY ;  : @GreaterEqual   ge  BINARY ;
: @Equal      eq  BINARY ;  : @NotEqual       ne  BINARY ;
: @And        and BINARY ;  : @Or             or  BINARY ;

: REVERSE ( l -- l')  0 SWAP
   BEGIN DUP WHILE TUCK DUP @  ROT ROT  ! REPEAT  DROP ;
: .STRINGS   STRINGS @ REVERSE  BEGIN DUP
   WHILE DUP FIRST COUNT "TYPE" CR @ REPEAT DROP ;
: .HEADER ( --)
   ." Datasize: " GLOBALS @ DEPTH . SPACE
   ." Strings: "  STRINGS @ DEPTH . CR  .STRINGS ;
: GENERATE ( ast -- addr u)
   0 PC ! HERE >R  GEN halt i8,  R> PC @ ;
: ,"   [CHAR] " PARSE TUCK HERE SWAP CMOVE ALLOT ;
CREATE "OPS"
," fetch store push  jmp   jz    prtc  prti  prts  "
," neg   not   add   sub   mul   div   mod   lt    "
," gt    le    ge    eq    ne    and   or    halt  "
: .i32   [email protected]+ . ;
: .[i32]   [CHAR] [ EMIT .i32 [CHAR] ] EMIT ;
: .off   [CHAR] ( EMIT PC @ >R [email protected]+ DUP R> - . [CHAR] ) EMIT
    SPACE . ;
CREATE .INT ' .[i32] , ' .[i32] , ' .i32 , ' .off , ' .off ,
: EMIT ( addr u --)  >R 0 PC !
   BEGIN PC @ [email protected] <
   WHILE PC @ 5 .R SPACE  [email protected]+
     DUP 6 * "OPS" + 6 TYPE
     DUP 5 < IF CELLS .INT + @ EXECUTE ELSE DROP THEN CR
   REPEAT DROP R> DROP ;
GENERATE EMIT BYE