From: Marius Gavrilescu Date: Sat, 17 Mar 2018 15:26:54 +0000 (+0200) Subject: Add compiler X-Git-Url: http://git.ieval.ro/?a=commitdiff_plain;h=c6418cc5f2b700f908cc8f330664f38537690a14;p=yule.git Add compiler The compiler is currently written in Lisp. It should be rewritten in Perl. --- diff --git a/compiler.l b/compiler.l new file mode 100644 index 0000000..c999904 --- /dev/null +++ b/compiler.l @@ -0,0 +1,99 @@ +(ql:quickload "lisp-unit") + +(defpackage :compiler + (:use :common-lisp :lisp-unit)) +(in-package :compiler) + +(setq *print-failures* t) + +(defvar *primops*) +(setq *primops* '(car cdr cons atom progn reverse-list)) + +(defun process-quoted (exp) + (if (atom exp) + (if exp (if (numberp exp) (list 'number exp) (list 'symbol exp)) '(list 0)) + (list 'list (process-quoted (cdr exp)) (process-quoted (car exp))))) + +(define-test process-quoted + (assert-equal '(number 5) (process-quoted '5)) + (assert-equal '(list 0) (process-quoted '())) + (assert-equal '(symbol foo) (process-quoted 'foo)) + (assert-equal + '(list (list (list 0) (symbol foo)) (number 5)) + (process-quoted '(5 foo))) + (assert-equal + '(list (list 0) (list (list 0) (list (list 0) (number 5)))) + (process-quoted '(((5)))))) + +(defun process-proc (func-name func-args func-body env) + (process-toplevel func-body (append (cons func-name (reverse func-args)) env))) + +(defun rest-of-funcall (func args) + (if (atom args) func (list 'more (rest-of-funcall func (cdr args)) (car args)))) + +(defun process-funcall (func-name func-args env) + (let* ((prim-idx (position func-name *primops*)) + (processed-args (mapcar #'(lambda (exp) (process-toplevel exp env)) func-args))) + (if (numberp prim-idx) + (list 'call (rest-of-funcall (list func-name nil) (cdr processed-args)) (car processed-args)) + (let ((final-args (append processed-args (list (process-toplevel func-name env))))) + (list 'call (rest-of-funcall '(funcall nil) (cdr final-args)) (car final-args)))))) + +(defun process-toplevel (exp env) + (if (atom exp) + (if (numberp exp) + (list 'number exp) + (cond + ((equal exp 't) '(symbol t)) + ((equal exp 'nil) '(list 0)) + (t (let ((idx (position exp env))) + (if (numberp idx) + (list 'var (- -1 idx)) + (error "Variable ~a not in environment" exp)))))) + (let ((func (car exp))) + (cond + ((equal func 'quote) (process-quoted (cadr exp))) + ((equal func 'lambda) (destructuring-bind (func-name func-args func-body) (cdr exp) + (list 'proc (process-proc func-name func-args func-body env)))) + ((equal func 'if) (destructuring-bind (if-cond if-then if-else) (mapcar #'(lambda (exp) (process-toplevel exp env)) (cdr exp)) (list 'if (list 'list if-else if-then) if-cond))) + (t (process-funcall func (cdr exp) env)) + )))) + +(define-test process-toplevel-quote + (assert-equal '(number 5) (process-toplevel '(quote 5) ()))) + +(define-test process-toplevel-if + (assert-equal + '(if (list (symbol x) (list (list (list 0) (number 3)) (number 2))) (symbol t)) + (process-toplevel '(if t '(2 3) 'x) ()))) + +(define-test process-toplevel-cdr + (assert-equal + '(call (car nil) (list (list (list 0) (number 2)) (number 1))) + (process-toplevel '(car '(1 2)) ()))) + +(define-test process-toplevel-lambda + (assert-equal + '(proc (var -2)) + (process-toplevel '(lambda id (x) x) ()))) + +(define-test process-toplevel-funcall + (assert-equal + '(call (more (funcall nil) (proc (var -2))) (number 5)) + (process-toplevel '((lambda id (x) x) 5) ()))) + +(define-test process-toplevel-append + (assert-equal + '(proc (if (list (call (more (cons nil) (call (more (more (funcall nil) (var -1)) (var -2)) (call (cdr nil) (var -3)))) (call (car nil) (var -3))) (var -2)) (call (atom nil) (var -3)))) + (process-toplevel '(lambda append (x y) (if (atom x) y (cons (car x) (append (cdr x) y)))) ()) + )) + +(define-test process-toplevel-append-call + (assert-equal + '(call (more (more (funcall nil) (proc (if (list (call (more (cons nil) (call (more (more (funcall nil) (var -1)) (var -2)) (call (cdr nil) (var -3)))) (call (car nil) (var -3))) (var -2)) (call (atom nil) (var -3))))) (list (list (list (list 0) (symbol f)) (symbol e)) (symbol d))) (list (list (list (list 0) (symbol c)) (symbol b)) (symbol a))) + (process-toplevel '((lambda append (x y) (if (atom x) y (cons (car x) (append (cdr x) y)))) '(a b c) '(d e f)) ()))) + +; (run-tests) + +; read a sexp, process it, print the result +(prin1 (process-toplevel (read) ()))