WIP: add compiler
This commit is contained in:
Yuichi Nishiwaki
parent
c1a7f6d2d8
commit
1e345d8228
|
|
@ -35,6 +35,7 @@
|
||||||
(scheme time)
|
(scheme time)
|
||||||
(scheme eval)
|
(scheme eval)
|
||||||
(scheme r5rs)
|
(scheme r5rs)
|
||||||
|
(picrin pretty-print)
|
||||||
(picrin macro))
|
(picrin macro))
|
||||||
'(picrin user)))
|
'(picrin user)))
|
||||||
|
|
||||||
|
|
|
||||||
1312
lib/ext/boot.c
1312
lib/ext/boot.c
File diff suppressed because it is too large
Load Diff
|
|
@ -1,246 +1,256 @@
|
||||||
(define-values (make-identifier
|
(begin
|
||||||
identifier?
|
|
||||||
identifier=?
|
;; expand
|
||||||
identifier-name
|
|
||||||
identifier-environment
|
(define-values (make-identifier
|
||||||
make-environment
|
identifier?
|
||||||
default-environment
|
identifier=?
|
||||||
environment?
|
identifier-name
|
||||||
find-identifier
|
identifier-environment
|
||||||
add-identifier!
|
make-environment
|
||||||
set-identifier!
|
default-environment
|
||||||
macro-objects
|
environment?
|
||||||
compile
|
find-identifier
|
||||||
eval)
|
add-identifier!
|
||||||
|
set-identifier!
|
||||||
|
macro-objects
|
||||||
|
expand)
|
||||||
|
(let ()
|
||||||
|
|
||||||
|
;; identifier
|
||||||
|
|
||||||
|
(define-record-type identifier
|
||||||
|
(make-identifier name env)
|
||||||
|
%identifier?
|
||||||
|
(name identifier-name)
|
||||||
|
(env identifier-environment))
|
||||||
|
|
||||||
|
(define (identifier? obj)
|
||||||
|
(or (symbol? obj) (%identifier? obj)))
|
||||||
|
|
||||||
|
(define (identifier=? id1 id2)
|
||||||
|
(cond
|
||||||
|
((and (symbol? id1) (symbol? id2))
|
||||||
|
(eq? id1 id2))
|
||||||
|
((and (%identifier? id1) (%identifier? id2))
|
||||||
|
(eq? (find-identifier (identifier-name id1) (identifier-environment id1))
|
||||||
|
(find-identifier (identifier-name id2) (identifier-environment id2))))
|
||||||
|
(else
|
||||||
|
#f)))
|
||||||
|
|
||||||
|
(set! equal?
|
||||||
|
(let ((e? equal?))
|
||||||
|
(lambda (x y)
|
||||||
|
(if (%identifier? x)
|
||||||
|
(identifier=? x y)
|
||||||
|
(e? x y)))))
|
||||||
|
|
||||||
|
|
||||||
|
;; environment
|
||||||
|
|
||||||
|
(define-record-type environment
|
||||||
|
(%make-environment parent prefix binding)
|
||||||
|
environment?
|
||||||
|
(parent environment-parent)
|
||||||
|
(prefix environment-prefix)
|
||||||
|
(binding environment-binding))
|
||||||
|
|
||||||
|
(define (search-scope id env)
|
||||||
|
((environment-binding env) id))
|
||||||
|
|
||||||
|
(define (find-identifier id env)
|
||||||
|
(or (search-scope id env)
|
||||||
|
(let ((parent (environment-parent env)))
|
||||||
|
(if parent
|
||||||
|
(find-identifier id parent)
|
||||||
|
(if (symbol? id)
|
||||||
|
(add-identifier! id env)
|
||||||
|
(find-identifier (identifier-name id)
|
||||||
|
(identifier-environment id)))))))
|
||||||
|
|
||||||
|
(define add-identifier!
|
||||||
|
(let ((uniq
|
||||||
|
(let ((n 0))
|
||||||
|
(lambda (id)
|
||||||
|
(let ((m n))
|
||||||
|
(set! n (+ n 1))
|
||||||
|
(string->symbol
|
||||||
|
(string-append
|
||||||
|
"."
|
||||||
|
(symbol->string
|
||||||
|
(let loop ((id id))
|
||||||
|
(if (symbol? id)
|
||||||
|
id
|
||||||
|
(loop (identifier-name id)))))
|
||||||
|
"."
|
||||||
|
(number->string m))))))))
|
||||||
|
(lambda (id env)
|
||||||
|
(or (search-scope id env)
|
||||||
|
(if (and (not (environment-parent env)) (symbol? id))
|
||||||
|
(string->symbol
|
||||||
|
(string-append
|
||||||
|
(environment-prefix env)
|
||||||
|
(symbol->string id)))
|
||||||
|
(let ((uid (uniq id)))
|
||||||
|
(set-identifier! id uid env)
|
||||||
|
uid))))))
|
||||||
|
|
||||||
|
(define (set-identifier! id uid env)
|
||||||
|
((environment-binding env) id uid))
|
||||||
|
|
||||||
|
(define (make-environment prefix)
|
||||||
|
(%make-environment #f (symbol->string prefix) (make-ephemeron-table)))
|
||||||
|
|
||||||
|
(define default-environment
|
||||||
|
(let ((env (make-environment (string->symbol ""))))
|
||||||
|
(for-each
|
||||||
|
(lambda (x) (set-identifier! x x env))
|
||||||
|
'(core#define
|
||||||
|
core#set!
|
||||||
|
core#quote
|
||||||
|
core#lambda
|
||||||
|
core#if
|
||||||
|
core#begin
|
||||||
|
core#define-macro))
|
||||||
|
env))
|
||||||
|
|
||||||
|
(define (extend-environment parent)
|
||||||
|
(%make-environment parent #f (make-ephemeron-table)))
|
||||||
|
|
||||||
|
|
||||||
|
;; macro
|
||||||
|
|
||||||
|
(define global-macro-table
|
||||||
|
(make-dictionary))
|
||||||
|
|
||||||
|
(define (find-macro uid)
|
||||||
|
(and (dictionary-has? global-macro-table uid)
|
||||||
|
(dictionary-ref global-macro-table uid)))
|
||||||
|
|
||||||
|
(define (add-macro! uid expander) ; TODO warn on redefinition
|
||||||
|
(dictionary-set! global-macro-table uid expander))
|
||||||
|
|
||||||
|
(define (shadow-macro! uid)
|
||||||
|
(when (dictionary-has? global-macro-table uid)
|
||||||
|
(dictionary-delete! global-macro-table uid)))
|
||||||
|
|
||||||
|
(define (macro-objects)
|
||||||
|
global-macro-table)
|
||||||
|
|
||||||
|
|
||||||
|
;; expander
|
||||||
|
|
||||||
|
(define expand
|
||||||
|
(let ((task-queue (make-parameter '())))
|
||||||
|
|
||||||
|
(define (queue task)
|
||||||
|
(let ((tmp (cons #f #f)))
|
||||||
|
(task-queue `((,tmp . ,task) . ,(task-queue)))
|
||||||
|
tmp))
|
||||||
|
|
||||||
|
(define (run-all)
|
||||||
|
(for-each
|
||||||
|
(lambda (x)
|
||||||
|
(let ((task (cdr x)) (skelton (car x)))
|
||||||
|
(let ((x (task)))
|
||||||
|
(set-car! skelton (car x))
|
||||||
|
(set-cdr! skelton (cdr x)))))
|
||||||
|
(reverse (task-queue))))
|
||||||
|
|
||||||
|
(define (caddr x) (car (cddr x)))
|
||||||
|
|
||||||
|
(define (map* proc list*)
|
||||||
|
(cond
|
||||||
|
((null? list*) list*)
|
||||||
|
((pair? list*) (cons (proc (car list*)) (map* proc (cdr list*))))
|
||||||
|
(else (proc list*))))
|
||||||
|
|
||||||
|
(define (literal? x)
|
||||||
|
(not (or (identifier? x) (pair? x))))
|
||||||
|
|
||||||
|
(define (call? x)
|
||||||
|
(and (list? x)
|
||||||
|
(not (null? x))
|
||||||
|
(identifier? (car x))))
|
||||||
|
|
||||||
|
(define (expand-variable var env)
|
||||||
|
(let ((x (find-identifier var env)))
|
||||||
|
(let ((m (find-macro x)))
|
||||||
|
(if m
|
||||||
|
(expand-node (m var env) env)
|
||||||
|
x))))
|
||||||
|
|
||||||
|
(define (expand-quote obj)
|
||||||
|
`(core#quote ,obj))
|
||||||
|
|
||||||
|
(define (expand-define var form env)
|
||||||
|
(let ((uid (add-identifier! var env)))
|
||||||
|
(shadow-macro! uid)
|
||||||
|
`(core#define ,uid ,(expand-node form env))))
|
||||||
|
|
||||||
|
(define (expand-lambda args body env)
|
||||||
|
(let ((env (extend-environment env)))
|
||||||
|
(let ((args (map* (lambda (var) (add-identifier! var env)) args)))
|
||||||
|
(parameterize ((task-queue '()))
|
||||||
|
(let ((body (expand-node body env)))
|
||||||
|
(run-all)
|
||||||
|
`(core#lambda ,args ,body))))))
|
||||||
|
|
||||||
|
(define (expand-define-macro var transformer env)
|
||||||
|
(let ((uid (add-identifier! var env)))
|
||||||
|
(let ((expander (load (expand transformer env))))
|
||||||
|
(add-macro! uid expander)
|
||||||
|
#undefined)))
|
||||||
|
|
||||||
|
(define (expand-node expr env)
|
||||||
|
(cond
|
||||||
|
((literal? expr) expr)
|
||||||
|
((identifier? expr) (expand-variable expr env))
|
||||||
|
((call? expr)
|
||||||
|
(let ((functor (find-identifier (car expr) env)))
|
||||||
|
(case functor
|
||||||
|
((core#quote) (expand-quote (cadr expr)))
|
||||||
|
((core#define) (expand-define (cadr expr) (caddr expr) env))
|
||||||
|
((core#lambda) (queue (lambda () (expand-lambda (cadr expr) (caddr expr) env))))
|
||||||
|
((core#define-macro) (expand-define-macro (cadr expr) (caddr expr) env))
|
||||||
|
(else
|
||||||
|
(let ((m (find-macro functor)))
|
||||||
|
(if m
|
||||||
|
(expand-node (m expr env) env)
|
||||||
|
(map (lambda (x) (expand-node x env)) expr)))))))
|
||||||
|
((list? expr)
|
||||||
|
(map (lambda (x) (expand-node x env)) expr))
|
||||||
|
(else
|
||||||
|
(error "invalid expression" expr))))
|
||||||
|
|
||||||
|
(define (expand expr env)
|
||||||
|
(let ((x (expand-node expr env)))
|
||||||
|
(run-all)
|
||||||
|
x))
|
||||||
|
|
||||||
|
expand))
|
||||||
|
|
||||||
|
(values make-identifier
|
||||||
|
identifier?
|
||||||
|
identifier=?
|
||||||
|
identifier-name
|
||||||
|
identifier-environment
|
||||||
|
make-environment
|
||||||
|
default-environment
|
||||||
|
environment?
|
||||||
|
find-identifier
|
||||||
|
add-identifier!
|
||||||
|
set-identifier!
|
||||||
|
macro-objects
|
||||||
|
expand)))
|
||||||
|
|
||||||
|
|
||||||
|
;; built-in macros
|
||||||
|
|
||||||
(let ()
|
(let ()
|
||||||
|
|
||||||
;; identifier
|
|
||||||
|
|
||||||
(define-record-type identifier
|
|
||||||
(make-identifier name env)
|
|
||||||
%identifier?
|
|
||||||
(name identifier-name)
|
|
||||||
(env identifier-environment))
|
|
||||||
|
|
||||||
(define (identifier? obj)
|
|
||||||
(or (symbol? obj) (%identifier? obj)))
|
|
||||||
|
|
||||||
(define (identifier=? id1 id2)
|
|
||||||
(cond
|
|
||||||
((and (symbol? id1) (symbol? id2))
|
|
||||||
(eq? id1 id2))
|
|
||||||
((and (%identifier? id1) (%identifier? id2))
|
|
||||||
(eq? (find-identifier (identifier-name id1) (identifier-environment id1))
|
|
||||||
(find-identifier (identifier-name id2) (identifier-environment id2))))
|
|
||||||
(else
|
|
||||||
#f)))
|
|
||||||
|
|
||||||
(set! equal?
|
|
||||||
(let ((e? equal?))
|
|
||||||
(lambda (x y)
|
|
||||||
(if (%identifier? x)
|
|
||||||
(identifier=? x y)
|
|
||||||
(e? x y)))))
|
|
||||||
|
|
||||||
|
|
||||||
;; environment
|
|
||||||
|
|
||||||
(define-record-type environment
|
|
||||||
(%make-environment parent prefix binding)
|
|
||||||
environment?
|
|
||||||
(parent environment-parent)
|
|
||||||
(prefix environment-prefix)
|
|
||||||
(binding environment-binding))
|
|
||||||
|
|
||||||
(define (search-scope id env)
|
|
||||||
((environment-binding env) id))
|
|
||||||
|
|
||||||
(define (find-identifier id env)
|
|
||||||
(or (search-scope id env)
|
|
||||||
(let ((parent (environment-parent env)))
|
|
||||||
(if parent
|
|
||||||
(find-identifier id parent)
|
|
||||||
(if (symbol? id)
|
|
||||||
(add-identifier! id env)
|
|
||||||
(find-identifier (identifier-name id)
|
|
||||||
(identifier-environment id)))))))
|
|
||||||
|
|
||||||
(define add-identifier!
|
|
||||||
(let ((uniq
|
|
||||||
(let ((n 0))
|
|
||||||
(lambda (id)
|
|
||||||
(let ((m n))
|
|
||||||
(set! n (+ n 1))
|
|
||||||
(string->symbol
|
|
||||||
(string-append
|
|
||||||
"."
|
|
||||||
(symbol->string
|
|
||||||
(let loop ((id id))
|
|
||||||
(if (symbol? id)
|
|
||||||
id
|
|
||||||
(loop (identifier-name id)))))
|
|
||||||
"."
|
|
||||||
(number->string m))))))))
|
|
||||||
(lambda (id env)
|
|
||||||
(or (search-scope id env)
|
|
||||||
(if (and (not (environment-parent env)) (symbol? id))
|
|
||||||
(string->symbol
|
|
||||||
(string-append
|
|
||||||
(environment-prefix env)
|
|
||||||
(symbol->string id)))
|
|
||||||
(let ((uid (uniq id)))
|
|
||||||
(set-identifier! id uid env)
|
|
||||||
uid))))))
|
|
||||||
|
|
||||||
(define (set-identifier! id uid env)
|
|
||||||
((environment-binding env) id uid))
|
|
||||||
|
|
||||||
(define (make-environment prefix)
|
|
||||||
(%make-environment #f (symbol->string prefix) (make-ephemeron-table)))
|
|
||||||
|
|
||||||
(define default-environment
|
|
||||||
(let ((env (make-environment (string->symbol ""))))
|
|
||||||
(for-each
|
|
||||||
(lambda (x) (set-identifier! x x env))
|
|
||||||
'(core#define
|
|
||||||
core#set!
|
|
||||||
core#quote
|
|
||||||
core#lambda
|
|
||||||
core#if
|
|
||||||
core#begin
|
|
||||||
core#define-macro))
|
|
||||||
env))
|
|
||||||
|
|
||||||
(define (extend-environment parent)
|
|
||||||
(%make-environment parent #f (make-ephemeron-table)))
|
|
||||||
|
|
||||||
|
|
||||||
;; macro
|
|
||||||
|
|
||||||
(define global-macro-table
|
|
||||||
(make-dictionary))
|
|
||||||
|
|
||||||
(define (find-macro uid)
|
|
||||||
(and (dictionary-has? global-macro-table uid)
|
|
||||||
(dictionary-ref global-macro-table uid)))
|
|
||||||
|
|
||||||
(define (add-macro! uid expander) ; TODO warn on redefinition
|
|
||||||
(dictionary-set! global-macro-table uid expander))
|
|
||||||
|
|
||||||
(define (shadow-macro! uid)
|
|
||||||
(when (dictionary-has? global-macro-table uid)
|
|
||||||
(dictionary-delete! global-macro-table uid)))
|
|
||||||
|
|
||||||
(define (macro-objects)
|
|
||||||
global-macro-table)
|
|
||||||
|
|
||||||
|
|
||||||
;; expander
|
|
||||||
|
|
||||||
(define expand
|
|
||||||
(let ((task-queue (make-parameter '())))
|
|
||||||
|
|
||||||
(define (queue task)
|
|
||||||
(let ((tmp (cons #f #f)))
|
|
||||||
(task-queue `((,tmp . ,task) . ,(task-queue)))
|
|
||||||
tmp))
|
|
||||||
|
|
||||||
(define (run-all)
|
|
||||||
(for-each
|
|
||||||
(lambda (x)
|
|
||||||
(let ((task (cdr x)) (skelton (car x)))
|
|
||||||
(let ((x (task)))
|
|
||||||
(set-car! skelton (car x))
|
|
||||||
(set-cdr! skelton (cdr x)))))
|
|
||||||
(reverse (task-queue))))
|
|
||||||
|
|
||||||
(define (caddr x) (car (cddr x)))
|
|
||||||
|
|
||||||
(define (map* proc list*)
|
|
||||||
(cond
|
|
||||||
((null? list*) list*)
|
|
||||||
((pair? list*) (cons (proc (car list*)) (map* proc (cdr list*))))
|
|
||||||
(else (proc list*))))
|
|
||||||
|
|
||||||
(define (literal? x)
|
|
||||||
(not (or (identifier? x) (pair? x))))
|
|
||||||
|
|
||||||
(define (call? x)
|
|
||||||
(and (list? x)
|
|
||||||
(not (null? x))
|
|
||||||
(identifier? (car x))))
|
|
||||||
|
|
||||||
(define (expand-variable var env)
|
|
||||||
(let ((x (find-identifier var env)))
|
|
||||||
(let ((m (find-macro x)))
|
|
||||||
(if m
|
|
||||||
(expand-node (m var env) env)
|
|
||||||
x))))
|
|
||||||
|
|
||||||
(define (expand-quote obj)
|
|
||||||
`(core#quote ,obj))
|
|
||||||
|
|
||||||
(define (expand-define var form env)
|
|
||||||
(let ((uid (add-identifier! var env)))
|
|
||||||
(shadow-macro! uid)
|
|
||||||
`(core#define ,uid ,(expand-node form env))))
|
|
||||||
|
|
||||||
(define (expand-lambda args body env)
|
|
||||||
(let ((env (extend-environment env)))
|
|
||||||
(let ((args (map* (lambda (var) (add-identifier! var env)) args)))
|
|
||||||
(parameterize ((task-queue '()))
|
|
||||||
(let ((body (expand-node body env)))
|
|
||||||
(run-all)
|
|
||||||
`(core#lambda ,args ,body))))))
|
|
||||||
|
|
||||||
(define (expand-define-macro var transformer env)
|
|
||||||
(let ((uid (add-identifier! var env)))
|
|
||||||
(let ((expander (load (expand transformer env))))
|
|
||||||
(add-macro! uid expander)
|
|
||||||
#undefined)))
|
|
||||||
|
|
||||||
(define (expand-node expr env)
|
|
||||||
(cond
|
|
||||||
((literal? expr) expr)
|
|
||||||
((identifier? expr) (expand-variable expr env))
|
|
||||||
((call? expr)
|
|
||||||
(let ((functor (find-identifier (car expr) env)))
|
|
||||||
(case functor
|
|
||||||
((core#quote) (expand-quote (cadr expr)))
|
|
||||||
((core#define) (expand-define (cadr expr) (caddr expr) env))
|
|
||||||
((core#lambda) (queue (lambda () (expand-lambda (cadr expr) (caddr expr) env))))
|
|
||||||
((core#define-macro) (expand-define-macro (cadr expr) (caddr expr) env))
|
|
||||||
(else
|
|
||||||
(let ((m (find-macro functor)))
|
|
||||||
(if m
|
|
||||||
(expand-node (m expr env) env)
|
|
||||||
(map (lambda (x) (expand-node x env)) expr)))))))
|
|
||||||
((list? expr)
|
|
||||||
(map (lambda (x) (expand-node x env)) expr))
|
|
||||||
(else
|
|
||||||
(error "invalid expression" expr))))
|
|
||||||
|
|
||||||
(define (expand expr env)
|
|
||||||
(let ((x (expand-node expr env)))
|
|
||||||
(run-all)
|
|
||||||
x))
|
|
||||||
|
|
||||||
expand))
|
|
||||||
|
|
||||||
;; compile
|
|
||||||
|
|
||||||
(define (compile expr . env)
|
|
||||||
(expand expr (if (null? env) default-environment (car env))))
|
|
||||||
|
|
||||||
;; eval
|
|
||||||
|
|
||||||
(define (eval expr . env)
|
|
||||||
(load (compile expr (if (null? env) default-environment (car env)))))
|
|
||||||
|
|
||||||
;; built-in macros
|
|
||||||
|
|
||||||
(define (define-transformer name transformer)
|
(define (define-transformer name transformer)
|
||||||
(dictionary-set! global-macro-table name transformer))
|
(dictionary-set! (macro-objects) name transformer))
|
||||||
|
|
||||||
(define (the var)
|
(define (the var)
|
||||||
(make-identifier var default-environment))
|
(make-identifier var default-environment))
|
||||||
|
|
@ -601,20 +611,275 @@
|
||||||
(,the-if (,pred obj)
|
(,the-if (,pred obj)
|
||||||
(,(the 'vector-set!) (,(the 'record-datum) obj) ,pos value)
|
(,(the 'vector-set!) (,(the 'record-datum) obj) ,pos value)
|
||||||
(,(the 'error) "record type mismatch" obj ',type))))))))
|
(,(the 'error) "record type mismatch" obj ',type))))))))
|
||||||
(loop (cdr fields) (+ pos 1) `(,@defs . ,acc)))))))))))
|
(loop (cdr fields) (+ pos 1) `(,@defs . ,acc))))))))))))
|
||||||
|
|
||||||
(values make-identifier
|
;; compile
|
||||||
identifier?
|
|
||||||
identifier=?
|
(define-values (compile)
|
||||||
identifier-name
|
(let ()
|
||||||
identifier-environment
|
|
||||||
make-environment
|
(define (caddr x) (car (cddr x)))
|
||||||
default-environment
|
(define (cadddr x) (cadr (cddr x)))
|
||||||
environment?
|
(define (max a b) (if (< a b) b a))
|
||||||
find-identifier
|
(define (integer? n) (and (number? n) (exact? n)))
|
||||||
add-identifier!
|
|
||||||
set-identifier!
|
(define normalize
|
||||||
macro-objects
|
(let ((defs (make-parameter '())))
|
||||||
compile
|
|
||||||
eval)))
|
;; 1. remove core# prefix from keywords
|
||||||
|
;; 2. eliminates internal definitions by replacing with equivalent let & set!
|
||||||
|
;; 3. transform a var into (ref var)
|
||||||
|
;; 4. wrap raw constants with quote
|
||||||
|
|
||||||
|
;; TODO: warn redefinition, warn duplicate variables
|
||||||
|
|
||||||
|
(define (normalize e)
|
||||||
|
(cond
|
||||||
|
((symbol? e) `(ref ,e))
|
||||||
|
((not (pair? e)) `(quote ,e))
|
||||||
|
(else
|
||||||
|
(case (car e)
|
||||||
|
((core#quote) `(quote . ,(cdr e)))
|
||||||
|
((core#define)
|
||||||
|
(let ((var (cadr e)) (val (caddr e)))
|
||||||
|
(defs (cons var (defs)))
|
||||||
|
`(set! ,var ,(normalize val))))
|
||||||
|
((core#lambda)
|
||||||
|
(let ((args (cadr e)) (body (caddr e)))
|
||||||
|
(parameterize ((defs '()))
|
||||||
|
(let ((body (normalize body)))
|
||||||
|
(if (null? (defs))
|
||||||
|
`(lambda ,args ,body)
|
||||||
|
`(lambda ,args
|
||||||
|
((lambda ,(defs) ,body) ,@(map (lambda (_) #f) (defs)))))))))
|
||||||
|
((core#set!) `(set! . ,(map normalize (cdr e))))
|
||||||
|
((core#if) `(if . ,(map normalize (cdr e))))
|
||||||
|
((core#begin) `(begin . ,(map normalize (cdr e))))
|
||||||
|
(else
|
||||||
|
(map normalize e))))))
|
||||||
|
|
||||||
|
normalize))
|
||||||
|
|
||||||
|
|
||||||
|
(define transform
|
||||||
|
(let ()
|
||||||
|
|
||||||
|
;; tail-conscious higher-order CPS transformation
|
||||||
|
|
||||||
|
;; target language
|
||||||
|
;; E ::= A
|
||||||
|
;; | (if A E E)
|
||||||
|
;; | (set! v A E)
|
||||||
|
;; | (A A ...)
|
||||||
|
;; A ::= (lambda (var ...) E)
|
||||||
|
;; | (ref v)
|
||||||
|
;; | (quote x)
|
||||||
|
;; | (undefined)
|
||||||
|
|
||||||
|
(define uniq
|
||||||
|
(let ((n 0))
|
||||||
|
(lambda ()
|
||||||
|
(set! n (+ n 1))
|
||||||
|
(string->symbol
|
||||||
|
(string-append "$" (number->string n))))))
|
||||||
|
|
||||||
|
(define (transform-k e k)
|
||||||
|
(case (car e)
|
||||||
|
((ref lambda quote) (k (transform-v e)))
|
||||||
|
((begin) (transform-k (cadr e)
|
||||||
|
(lambda (_)
|
||||||
|
(transform-k (caddr e) k))))
|
||||||
|
((set!) (transform-k (caddr e)
|
||||||
|
(lambda (v)
|
||||||
|
`(set! ,(cadr e) ,v ,(k '(undefined))))))
|
||||||
|
((if) (let ((v (uniq))
|
||||||
|
(c `(ref ,(uniq))))
|
||||||
|
`((lambda (,c)
|
||||||
|
,(transform-k (cadr e)
|
||||||
|
(lambda (x)
|
||||||
|
`(if ,x
|
||||||
|
,(transform-c (caddr e) c)
|
||||||
|
,(transform-c (cadddr e) c)))))
|
||||||
|
(lambda (,v) ,(k `(ref ,v))))))
|
||||||
|
(else
|
||||||
|
(let* ((v (uniq))
|
||||||
|
(c `(lambda (,v) ,(k `(ref ,v)))))
|
||||||
|
(transform-k (car e)
|
||||||
|
(lambda (f)
|
||||||
|
(transform*-k (cdr e)
|
||||||
|
(lambda (args)
|
||||||
|
`(,f ,c ,@args)))))))))
|
||||||
|
|
||||||
|
(define (transform*-k es k)
|
||||||
|
(if (null? es)
|
||||||
|
(k '())
|
||||||
|
(transform-k (car es)
|
||||||
|
(lambda (x)
|
||||||
|
(transform*-k (cdr es)
|
||||||
|
(lambda (xs)
|
||||||
|
(k (cons x xs))))))))
|
||||||
|
|
||||||
|
(define (transform-c e c)
|
||||||
|
(case (car e)
|
||||||
|
((ref lambda quote) `(,c ,(transform-v e)))
|
||||||
|
((begin) (transform-k (cadr e)
|
||||||
|
(lambda (_)
|
||||||
|
(transform-c (caddr e) c))))
|
||||||
|
((set!) (transform-k (caddr e)
|
||||||
|
(lambda (v)
|
||||||
|
`(set! ,(cadr e) ,v (,c (undefined))))))
|
||||||
|
((if) (if (and (pair? c) (eq? 'lambda (car c)))
|
||||||
|
(let ((k `(ref ,(uniq))))
|
||||||
|
`((lambda (,k)
|
||||||
|
,(transform-k (cadr e)
|
||||||
|
(lambda (x)
|
||||||
|
`(if ,x
|
||||||
|
,(transform-c (caddr e) k)
|
||||||
|
,(transform-c (cadddr e) k)))))
|
||||||
|
,c))
|
||||||
|
(transform-k (cadr e)
|
||||||
|
(lambda (x)
|
||||||
|
`(if ,x
|
||||||
|
,(transform-c (caddr e) c)
|
||||||
|
,(transform-c (cadddr e) c))))))
|
||||||
|
(else
|
||||||
|
(transform-k (car e)
|
||||||
|
(lambda (f)
|
||||||
|
(transform*-k (cdr e)
|
||||||
|
(lambda (args)
|
||||||
|
`(,f ,c ,@args))))))))
|
||||||
|
|
||||||
|
(define (transform-v e)
|
||||||
|
(case (car e)
|
||||||
|
((ref quote) e)
|
||||||
|
((lambda)
|
||||||
|
(let ((k (uniq)))
|
||||||
|
`(lambda (,k ,@(cadr e)) ,(transform-c (caddr e) `(ref ,k)))))))
|
||||||
|
|
||||||
|
(lambda (e)
|
||||||
|
(let ((k (uniq)))
|
||||||
|
`(lambda (,k) ,(transform-c e `(ref ,k)))))))
|
||||||
|
|
||||||
|
|
||||||
|
(define codegen
|
||||||
|
(let ()
|
||||||
|
|
||||||
|
;; TODO: check range of index/depth/frame_size/irepc/objc
|
||||||
|
|
||||||
|
(define (lookup var env)
|
||||||
|
(let up ((depth 0) (env env))
|
||||||
|
(if (null? env)
|
||||||
|
`(global ,var)
|
||||||
|
(let loop ((index 1) (binding (car env)))
|
||||||
|
(if (symbol? binding)
|
||||||
|
(if (eq? var binding)
|
||||||
|
`(local ,depth ,index)
|
||||||
|
(up (+ depth 1) (cdr env)))
|
||||||
|
(if (null? binding)
|
||||||
|
(up (+ depth 1) (cdr env))
|
||||||
|
(if (eq? var (car binding))
|
||||||
|
`(local ,depth ,index)
|
||||||
|
(loop (+ index 1) (cdr binding)))))))))
|
||||||
|
|
||||||
|
(define env (make-parameter '()))
|
||||||
|
(define code (make-parameter '()))
|
||||||
|
(define reps (make-parameter '()))
|
||||||
|
(define objs (make-parameter '()))
|
||||||
|
|
||||||
|
(define (emit inst)
|
||||||
|
(code (cons inst (code))))
|
||||||
|
|
||||||
|
(define (emit-irep irep)
|
||||||
|
(let ((n (length (reps))))
|
||||||
|
(reps (cons irep (reps)))
|
||||||
|
n))
|
||||||
|
|
||||||
|
(define (emit-objs obj) ; TODO remove duplicates
|
||||||
|
(let ((n (length (objs))))
|
||||||
|
(objs (cons obj (objs)))
|
||||||
|
n))
|
||||||
|
|
||||||
|
(define make-label
|
||||||
|
(let ((n 0))
|
||||||
|
(lambda ()
|
||||||
|
(let ((m n))
|
||||||
|
(set! n (+ n 1))
|
||||||
|
m))))
|
||||||
|
|
||||||
|
(define (emit-label label)
|
||||||
|
(code (cons label (code))))
|
||||||
|
|
||||||
|
(define (codegen-e e)
|
||||||
|
(case (car e)
|
||||||
|
((ref lambda quote undefined) (codegen-a e 0))
|
||||||
|
((set!) (begin
|
||||||
|
(codegen-a (caddr e) 0)
|
||||||
|
(let* ((x (lookup (cadr e) (env)))
|
||||||
|
(op (if (eq? 'global (car x)) 'GSET 'LSET)))
|
||||||
|
(emit `(,op 0 . ,(cdr x))))
|
||||||
|
(codegen-e (cadddr e))))
|
||||||
|
((if) (begin
|
||||||
|
(codegen-a (cadr e) 0)
|
||||||
|
(let ((label (make-label)))
|
||||||
|
(emit `(COND 0 ,label))
|
||||||
|
(codegen-e (caddr e))
|
||||||
|
(emit-label label)
|
||||||
|
(codegen-e (cadddr e)))))
|
||||||
|
(else (begin
|
||||||
|
(let loop ((i 0) (e e))
|
||||||
|
(unless (null? e)
|
||||||
|
(codegen-a (car e) i)
|
||||||
|
(loop (+ i 1) (cdr e))))
|
||||||
|
(emit `(CALL ,(length e)))))))
|
||||||
|
|
||||||
|
(define (codegen-a e i)
|
||||||
|
(case (car e)
|
||||||
|
((ref) (let* ((x (lookup (cadr e) (env)))
|
||||||
|
(op (if (eq? 'global (car x)) 'GREF 'LREF)))
|
||||||
|
(emit `(,op ,i . ,(cdr x)))))
|
||||||
|
((quote) (let ((obj (cadr e)))
|
||||||
|
(cond ((eq? #t obj) (emit `(LOADT ,i)))
|
||||||
|
((eq? #f obj) (emit `(LOADF ,i)))
|
||||||
|
((null? obj) (emit `(LOADN ,i)))
|
||||||
|
((and (integer? obj) (<= -128 obj 127)) (emit `(LOADI ,i ,obj)))
|
||||||
|
(else (let ((n (emit-obj obj)))
|
||||||
|
(emit `(LOAD ,i ,n)))))))
|
||||||
|
((undefined) (emit `(LOADU ,i)))
|
||||||
|
((lambda) (let ((frame-size
|
||||||
|
(let loop ((e (caddr e)))
|
||||||
|
(case (car e)
|
||||||
|
((ref lambda quote undefined) 1)
|
||||||
|
((if) (max (loop (caddr e)) (loop (cadddr e))))
|
||||||
|
((set!) (loop (cadddr e)))
|
||||||
|
(else (+ 1 (length e))))))
|
||||||
|
(argc-varg
|
||||||
|
(let loop ((args (cadr e)) (c 0))
|
||||||
|
(if (symbol? args)
|
||||||
|
(cons (+ 1 c) #t)
|
||||||
|
(if (null? args)
|
||||||
|
(cons c #f)
|
||||||
|
(loop (cdr args) (+ 1 c)))))))
|
||||||
|
(let ((irep
|
||||||
|
(parameterize ((code '())
|
||||||
|
(env (cons (cadr e) (env)))
|
||||||
|
(reps '())
|
||||||
|
(objs '()))
|
||||||
|
(codegen-e (caddr e))
|
||||||
|
(list (reverse (code)) (reverse (reps)) (reverse (objs)) argc-varg frame-size))))
|
||||||
|
(let ((n (emit-irep irep)))
|
||||||
|
(emit `(PROC ,i ,n))))))))
|
||||||
|
|
||||||
|
(lambda (e)
|
||||||
|
(parameterize ((code '()) (env '()) (reps '()) (objs '()))
|
||||||
|
(codegen-e e)
|
||||||
|
(car (reps))))))
|
||||||
|
|
||||||
|
(lambda (e)
|
||||||
|
(codegen (transform (normalize e))))))
|
||||||
|
|
||||||
|
|
||||||
|
;; eval
|
||||||
|
|
||||||
|
(define (eval expr . env)
|
||||||
|
(load (expand expr (if (null? env) default-environment (car env))))))
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue