forth.scm

(use-modules (srfi srfi-1))

(define (push-number maybenum)
  (lambda (stack)
    (let ([number (string->number maybenum)])
      (when (not number) (raise (cons 'undefined-word maybenum)))
      (cons number stack))))

(define (read-forth dict prog)
  (let loop ([procs '()] [prog prog])
    (if (null? prog)
        (reverse procs)
        (if (string-ci=? (car prog) ":")
            (let ([prog (defword dict prog)])
              (loop procs prog))
            (loop (cons (hashtable-ref dict (car prog) (push-number (car prog))) procs) (cdr prog))))))

(define (eval-forth procs stack)
  (fold-left (lambda (stack proc) (proc stack)) stack procs))

(define (defword dict prog)
  (let*-values
    ([(words rest) (break (lambda (x) (string-ci=? x ";")) (cdr prog))]
	 [(procs) (read-forth dict (cdr words))])
    (when (string->number (car words)) (raise (cons 'defword-number (car words))))
    (hashtable-set! dict (car words)
                    (lambda (stack) (fold-left (lambda (stack proc) (proc stack)) stack procs)))
    (cdr rest)))

(define (make-dictionary)
  (let ([dict (make-hashtable string-ci-hash string-ci=?)]
        [binary (lambda (op) (lambda (stack) (cons (op (cadr stack) (car stack)) (cddr stack))))])
    (hashtable-set! dict "+" (binary +))
    (hashtable-set! dict "-" (binary -))
    (hashtable-set! dict "/" (binary quotient))
    (hashtable-set! dict "*" (binary *))
    (hashtable-set! dict "DROP" (lambda (stack) (cdr stack)))
    (hashtable-set! dict "DUP" (lambda (stack) (apply list (car stack) (car stack) (cdr stack))))
    (hashtable-set! dict "SWAP" (lambda (stack) (apply list (cadr stack) (car stack) (cddr stack))))
    (hashtable-set! dict "OVER" (lambda (stack) (cons (cadr stack) stack)))
    dict))

(define (forth program)
  (eval-forth (read-forth (make-dictionary) (string-tokenize (string-join program))) '()))