138 lines
5.4 KiB
Scheme
138 lines
5.4 KiB
Scheme
(import (scheme base)
|
|
(scheme file)
|
|
(scheme process-context)
|
|
(scheme write)
|
|
(only (srfi 13) string-delete string-index string-trim))
|
|
|
|
;; Mappings from operation symbols to internal procedures.
|
|
;; We define operations appropriate to virtual machine:
|
|
;; e.g. division must return an int, not a rational
|
|
;; boolean values are treated as numbers: 0 is false, other is true
|
|
(define *unary-ops*
|
|
(list (cons 'Negate (lambda (a) (- a)))
|
|
(cons 'Not (lambda (a) (if (zero? a) 1 0)))))
|
|
(define *binary-ops*
|
|
(let ((number-comp (lambda (op) (lambda (a b) (if (op a b) 1 0)))))
|
|
(list (cons 'Add +)
|
|
(cons 'Subtract -)
|
|
(cons 'Multiply *)
|
|
(cons 'Divide (lambda (a b) (truncate (/ a b)))) ; int division
|
|
(cons 'Mod modulo)
|
|
(cons 'Less (number-comp <))
|
|
(cons 'Greater (number-comp >))
|
|
(cons 'LessEqual (number-comp <=))
|
|
(cons 'GreaterEqual (number-comp >=))
|
|
(cons 'Equal (lambda (a b) (if (= a b) 1 0)))
|
|
(cons 'NotEqual (lambda (a b) (if (= a b) 0 1)))
|
|
(cons 'And (lambda (a b) ; make "and" work on numbers
|
|
(if (and (not (zero? a)) (not (zero? b))) 1 0)))
|
|
(cons 'Or (lambda (a b) ; make "or" work on numbers
|
|
(if (or (not (zero? a)) (not (zero? b))) 1 0))))))
|
|
|
|
;; Read AST from given filename
|
|
;; - return as an s-expression
|
|
(define (read-code filename)
|
|
(define (read-expr)
|
|
(let ((line (string-trim (read-line))))
|
|
(if (string=? line ";")
|
|
'()
|
|
(let ((space (string-index line #\space)))
|
|
(if space
|
|
(list (string->symbol (string-trim (substring line 0 space)))
|
|
(string-trim (substring line space (string-length line))))
|
|
(list (string->symbol line) (read-expr) (read-expr)))))))
|
|
;
|
|
(with-input-from-file
|
|
filename
|
|
(lambda ()
|
|
(read-expr))))
|
|
|
|
;; interpret AST provided as an s-expression
|
|
(define run-program
|
|
(let ((env '())) ; env is an association list for variable names
|
|
(lambda (expr)
|
|
(define (tidy-string str)
|
|
(string-delete ; remove any quote marks
|
|
#\" ; " (to appease Rosetta code's syntax highlighter)
|
|
(list->string
|
|
(let loop ((chars (string->list str))) ; replace newlines, obeying \\n
|
|
(cond ((< (length chars) 2) ; finished list
|
|
chars)
|
|
((and (>= (length chars) 3) ; preserve \\n
|
|
(char=? #\\ (car chars))
|
|
(char=? #\\ (cadr chars))
|
|
(char=? #\n (cadr (cdr chars))))
|
|
(cons (car chars)
|
|
(cons (cadr chars)
|
|
(cons (cadr (cdr chars))
|
|
(loop (cdr (cdr (cdr chars))))))))
|
|
((and (char=? #\\ (car chars)) ; replace \n with newline
|
|
(char=? #\n (cadr chars)))
|
|
(cons #\newline (loop (cdr (cdr chars)))))
|
|
(else ; keep char and look further
|
|
(cons (car chars) (loop (cdr chars)))))))))
|
|
; define some more meaningful names for fields
|
|
(define left cadr)
|
|
(define right (lambda (x) (cadr (cdr x))))
|
|
;
|
|
(if (null? expr)
|
|
'()
|
|
(case (car expr) ; interpret AST from the head node
|
|
((Integer)
|
|
(string->number (left expr)))
|
|
((Identifier)
|
|
(let ((val (assq (string->symbol (left expr)) env)))
|
|
(if val
|
|
(cdr val)
|
|
(error "Variable not in environment"))))
|
|
((String)
|
|
(left expr))
|
|
((Assign)
|
|
(set! env (cons (cons (string->symbol (left (left expr)))
|
|
(run-program (right expr)))
|
|
env)))
|
|
((Add Subtract Multiply Divide Mod
|
|
Less Greater LessEqual GreaterEqual Equal NotEqual
|
|
And Or)
|
|
(let ((binop (assq (car expr) *binary-ops*)))
|
|
(if binop
|
|
((cdr binop) (run-program (left expr))
|
|
(run-program (right expr)))
|
|
(error "Could not find binary operator"))))
|
|
((Negate Not)
|
|
(let ((unaryop (assq (car expr) *unary-ops*)))
|
|
(if unaryop
|
|
((cdr unaryop) (run-program (left expr)))
|
|
(error "Could not find unary operator"))))
|
|
((If)
|
|
(if (not (zero? (run-program (left expr)))) ; 0 means false
|
|
(run-program (left (right expr)))
|
|
(run-program (right (right expr))))
|
|
'())
|
|
((While)
|
|
(let loop ()
|
|
(unless (zero? (run-program (left expr)))
|
|
(run-program (right expr))
|
|
(loop)))
|
|
'())
|
|
((Prtc)
|
|
(display (integer->char (run-program (left expr))))
|
|
'())
|
|
((Prti)
|
|
(display (run-program (left expr)))
|
|
'())
|
|
((Prts)
|
|
(display (tidy-string (run-program (left expr))))
|
|
'())
|
|
((Sequence)
|
|
(run-program (left expr))
|
|
(run-program (right expr))
|
|
'())
|
|
(else
|
|
(error "Unknown node type")))))))
|
|
|
|
;; read AST from file and interpret, from filename passed on command line
|
|
(if (= 2 (length (command-line)))
|
|
(run-program (read-code (cadr (command-line))))
|
|
(display "Error: pass an ast filename\n"))
|