Hello.
I'm trying translating the WhiteSpace language onto Racket, because it was originally written in Haskell, and that looks relatively easy to be written in Racket.
As you know, Haskell uses a bunch of Pattern Matching; therefore, I have to rely on the match of Racket, especially in the parsing process.
Original Source Code in Haskell
What I tried translating is like this:
#! /usr/bin/env racket
#lang racket
(require srfi/1 2htdp/batch-io)
(define (vm prog stack cstack heap pc)
(let ((instr (list-ref prog pc)))
((doInstr prog stack cstack heap (+ pc 1)) instr)))
;; Running individual instructions
(define (doInstr prog stack cs heap pc)
(lambda (instr)
(case (car instr)
((Push) (let ((n (cadr instr)))
(vm prog (cons n stack) cs heap pc)))
((Dup) (let ((n (car stack)))
(vm prog (cons n stack) cs heap pc)))
((Ref) (let ((i (cadr instr)))
(vm prog
(cons (list-ref stack i) stack)
cs heap pc)))
((Slide) (let ((i (cadr instr)) (n (car stack)))
(vm prog
(cons n (drop i (cdr stack)))
cs heap pc)))
((Swap) (let ((n (car stack)) (m (cadr stack)))
(vm prog
(cons m (cons n (cddr stack)))
cs heap pc)))
((Discard) (vm prog (cdr stack) cs heap pc))
((Infix) (let ((op (cadr instr))
(y (car stack))
(x (cadr stack)))
(vm prog
(cons ((case op
((Plus) +)
((Minul) -)
((Times) *)
((Divide) /)
((Modulo) modulo))
x y) (cddr stack))
cs heap pc)))
((OutputChar) (let ((n (car stack)))
(write-char (integer->char n))
(flush-output)
(vm prog (cdr stack) cs heap pc)))
((ReadChar) (let ((loc (car stack))
(ch (read-char)))
(let ((hp
(store (char->integer ch) loc heap)))
(vm prog (cdr stack) cs hp pc))))
((ReadNum) (let ((loc (car stack))
(ch (read-line)))
(let ((num (string->number ch)))
(let ((hp (store num loc heap)))
(vm prog (cdr stack) cs hp pc)))))
((OutputNum) (let ((n (car stack)))
(write-string (number->string n))
(flush-output)
(vm prog (cdr stack) cs heap pc)))
((Label) (let ((_ (cadr instr)))
(vm prog stack cs heap pc)))
((Call) (let ((l (cadr instr)))
(let ((loc (findLabel l prog)))
(vm prog stack (cons pc cs) heap loc))))
((Jump) (let ((l (cadr instr)))
(let ((loc (findLabel l prog)))
(vm prog stack cs heap loc))))
((If) (let ((t (cadr instr))
(l (caddr instr))
(n (car stack)))
(if ((case t
((Zero) zero?)
((Negative) negative?)) n)
(let ((loc (findLabel l prog)))
(vm prog (cdr stack) cs heap loc))
(vm prog (cdr stack) cs heap pc))))
((Return) (let ((c (car cs)))
(vm prog stack (cdr cs) heap c)))
((Store) (let ((n (car stack)) (loc (cadr stack)))
(let ((hp (store n loc heap)))
(vm prog stack cs hp pc))))
((Retrieve) (let ((loc (car stack)))
(let ((val (retrieve loc heap)))
(vm prog (cons val stack) cs heap pc))))
((End) #f)
(else (error "Can't do " instr)))))
;; Digging out labels from wherever they are
(define (findLabel l p)
(let loop ((m l) (p p) (i 0))
(if (null? p)
(error "Undefined label" l)
(let ((l (car p)))
(if (eqv? l m)
i
(loop m (cdr p) (+ i 1)))))))
;; Heap management
(define (retrieve x heap) (list-ref heap x))
(define (store x n Heap)
(cond ((zero? n) (if (null? Heap)
`(,x)
(cons x (cdr Heap))))
((null? Heap) (append (make-list n 0) `(,x)))
(else
(let-values (((head tail) (split-at Heap n)))
(append head `(,x) (cdr tail))))))
(define *A* #\space)
(define *B* #\tab)
(define *C* #\newline)
(define (execute fname)
(let ((prog (read-file fname)))
(let ((tokens (tokenize prog)))
(let ((runtime (parse tokens)))
(vm runtime '() '() '() 0)))))
(define (tokenize str)
(let loop ((ls (string->list str)) (acc '()))
(if (null? ls)
(reverse acc)
(let ((x (car ls)))
(loop (cdr ls) (if (or (char=? x *A*)
(char=? x *B*)
(char=? x *C*))
(cons x acc)
acc))))))
(define (parse ls)
(let loop ((ls ls) (acc '()))
(if (null? ls)
(reverse acc)
(match ls
((list *A* *A* xs ...)
(let-values (((num rest) (parseNumber xs)))
(loop rest (cons `(Push ,num) acc))))
((list *A* *C* *A* xs ...)
(loop xs (cons '(Dup) acc)))
((list *A* *B* *A* xs ...)
(let-values (((num rest) (parseNumber xs)))
(loop rest (cons `(Ref ,num) acc))))
((list *A* *B* *C* xs ...)
(let-values (((num rest) (parseNumber xs)))
(loop rest (cons `(Slide ,num) acc))))
((list *A* *C* *B* xs ...)
(loop xs (cons '(Swap) acc)))
((list *A* *C* *C* xs ...)
(loop xs (cons '(Discard) acc)))
((list *B* *A* *A* *A* xs ...)
(loop xs (cons '(Infix Plus) acc)))
((list *B* *A* *A* *B* xs ...)
(loop xs (cons '(Infix Minus) acc)))
((list *B* *A* *A* *C* xs ...)
(loop xs (cons '(Infix Times) acc)))
((list *B* *A* *B* *A* xs ...)
(loop xs (cons '(Infix Divide) acc)))
((list *B* *A* *B* *B* xs ...)
(loop xs (cons '(infix Modulo) acc)))
((list *B* *B* *A* xs ...)
(loop xs (cons '(Store) acc)))
((list *B* *B* *B* xs ...)
(loop xs (cons '(Retrieve) acc)))
((list *C* *A* *A* xs ...)
(let-values (((string rest) (parseString xs)))
(loop rest (cons `(Label ,string) acc))))
((list *C* *A* *B* xs ...)
(let-values (((string rest) (parseString xs)))
(loop rest (cons `(Call ,string) acc))))
((list *C* *A* *C* xs ...)
(let-values (((string rest) (parseString xs)))
(loop rest (cons `(Jump ,string) acc))))
((list *C* *B* *A* xs ...)
(let-values (((string rest) (parseString xs)))
(loop rest (cons `(If Zero ,string) acc))))
((list *C* *B* *B* xs ...)
(let-values (((string rest) (parseString xs)))
(loop rest (cons `(If Negative string) acc))))
((list *C* *B* *C* xs ...)
(let-values (((string rest) (parseString xs)))
(loop rest (cons '(Return) acc))))
((list *C* *C* *C* xs ...)
(loop xs (cons '(End) acc)))
((list *B* *C* *A* *A* xs ...)
(loop xs (cons '(OutputChar) acc)))
((list *B* *C* *A* *B* xs ...)
(loop xs (cons '(OutputNum) acc)))
((list *B* *C* *B* *A* xs ...)
(loop xs (cons '(ReadChar) acc)))
((list *B* *C* *B* *B* xs ...)
(loop xs (cons '(ReadNum) acc)))
(else (error "Unrecognised input"))))))
(define (parseNumber ts)
(let loop ((ts ts) (acc '()))
(let ((x (car ts)) (rest (cdr ts)))
(if (char=? x *C*)
(values (makeNumber acc) rest)
(loop rest (cons x acc))))))
(define (parseString ts)
(let loop ((ts ts) (acc '()))
(let ((x (car ts)) (rest (cdr ts)))
(if (char=? x *C*)
(values (makeString acc) rest)
(loop rest (cons x acc))))))
(define (makeNumber t)
(let ((sign (last t)) (ls (reverse (take t (- (length t) 1)))))
(if (null? ls)
0
(let ((num (string->number
(list->string
(map (lambda (x)
(cond ((char=? x *A*) #\0)
((char=? x *B*) #\1))) ls)) 2)))
(if (char=? sign *A*)
num
(- num))))))
(define makeString list->string)
(define (main args)
(if (not (= (length args) 1))
(usage)
(execute (car args))))
(define (usage)
(display "wspace with Racket 0.1 (c) 2021 Cametan\n")
(display "-------------------------------\n")
(display "Usage: wspace [file]\n"))
;(main (vector->list (current-command-line-arguments)))
I try running hello world on the program I wrote; however I noticed the pattern matching in the parsing process does not work properly.
To be specific, with the debugger, the pattern of #\space, #\tab, and #\newline only matches in the first clause, or (list A A xs ...), where A is #\space.
(This makes the accumulator, or acc, be a list, fully consisting of list of (Push n))
As a result, the program raises an Error.
Did I make any mistakes to use match of Racket?
Thanks.