;; Forth reader — whitespace-delimited tokens.

(define
  forth-whitespace?
  (fn (ch) (or (= ch " ") (or (= ch "\t") (or (= ch "\n") (= ch "\r"))))))

(define
  forth-tokens-loop
  (fn
    (src n i buf out)
    (if
      (>= i n)
      (if (> (len buf) 0) (concat out (list buf)) out)
      (let
        ((ch (char-at src i)))
        (if
          (forth-whitespace? ch)
          (if
            (> (len buf) 0)
            (forth-tokens-loop src n (+ i 1) "" (concat out (list buf)))
            (forth-tokens-loop src n (+ i 1) buf out))
          (forth-tokens-loop src n (+ i 1) (str buf ch) out))))))

(define
  forth-tokens
  (fn (src) (forth-tokens-loop src (len src) 0 "" (list))))

(define
  forth-digit-value
  (fn
    (ch base)
    (let
      ((code (char-code ch)) (cc (char-code (downcase ch))))
      (let
        ((v (if (and (>= code 48) (<= code 57)) (- code 48) (if (and (>= cc 97) (<= cc 122)) (+ 10 (- cc 97)) -1))))
        (if (and (>= v 0) (< v base)) v nil)))))

(define
  forth-parse-digits-loop
  (fn
    (src n i base acc)
    (if
      (>= i n)
      acc
      (let
        ((d (forth-digit-value (char-at src i) base)))
        (if
          (nil? d)
          nil
          (forth-parse-digits-loop src n (+ i 1) base (+ (* acc base) d)))))))

(define
  forth-parse-digits
  (fn
    (src base)
    (if
      (= (len src) 0)
      nil
      (forth-parse-digits-loop src (len src) 0 base 0))))

(define
  forth-strip-prefix
  (fn
    (s)
    (if
      (<= (len s) 1)
      (list s 0)
      (let
        ((c (char-at s 0)))
        (if
          (= c "$")
          (list (substring s 1 (len s)) 16)
          (if
            (= c "%")
            (list (substring s 1 (len s)) 2)
            (if (= c "#") (list (substring s 1 (len s)) 10) (list s 0))))))))

(define
  forth-parse-number
  (fn
    (tok base)
    (let
      ((n (len tok)))
      (if
        (= n 0)
        nil
        (if
          (and
            (= n 3)
            (and (= (char-at tok 0) "'") (= (char-at tok 2) "'")))
          (char-code (char-at tok 1))
          (let
            ((neg? (and (> n 1) (= (char-at tok 0) "-"))))
            (let
              ((s1 (if neg? (substring tok 1 n) tok)))
              (let
                ((pair (forth-strip-prefix s1)))
                (let
                  ((s (first pair)) (b-override (nth pair 1)))
                  (let
                    ((b (if (= b-override 0) base b-override)))
                    (let
                      ((v (forth-parse-digits s b)))
                      (if (nil? v) nil (if neg? (- 0 v) v)))))))))))))