conservatory/picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

reimplement macro expander in scheme

Browse Source
This commit is contained in:
Yuichi Nishiwaki
2017-04-04 15:05:34 +09:00
parent 82939650a4
commit 463b73f11f
23 changed files with 907 additions and 1088 deletions
Download Patch File Download Diff File Expand all files Collapse all files
piclib/boot.scm
+30 -1
View File
@@ -330,4 +330,33 @@
(body (cdr (cdr form))))
`(,(the 'with-dynamic-environment)
(,(the 'list) ,@(map (lambda (x) `(,(the 'cons) ,(car x) ,(cadr x))) formal))
(,the-lambda () ,@body)))))))
(,the-lambda () ,@body)))))
(define-transformer 'define-record-type
(lambda (form env)
(let ((type (car (cdr form)))
(ctor (car (cdr (cdr form))))
(pred (car (cdr (cdr (cdr form)))))
(fields (cdr (cdr (cdr (cdr form))))))
`(,the-begin
(,the-define ,ctor
(,(the 'make-record) ',type
(,(the 'vector) . ,(map (lambda (field) (if (memq (car field) (cdr ctor)) (car field) #undefined)) fields))))
(,the-define ,pred
(,(the 'lambda) (obj)
(,(the 'and) (,(the 'record?) obj) (,(the 'eq?) (,(the 'record-type) obj) ',type))))
. ,(let loop ((fields fields) (pos 0) (acc '()))
(if (null? fields)
acc
(let ((field (car fields)))
(let ((defs `((,the-define (,(cadr field) obj)
(,the-if (,pred obj)
(,(the 'vector-ref) (,(the 'record-datum) obj) ,pos)
(,(the 'error) "record type mismatch" obj ',type)))
. ,(if (null? (cddr field))
'()
`((,the-define (,(car (cddr field)) obj value)
(,the-if (,pred obj)
(,(the 'vector-set!) (,(the 'record-datum) obj) ,pos value)
(,(the 'error) "record type mismatch" obj ',type))))))))
(loop (cdr fields) (+ pos 1) `(,@defs . ,acc))))))))))))
piclib/compile.scm
+254
View File
@@ -0,0 +1,254 @@
(define-values (make-identifier
identifier?
identifier=?
identifier-name
identifier-environment
make-environment
default-environment
environment?
find-identifier
add-identifier!
set-identifier!
macro-objects
compile
eval)
(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)))))
(values make-identifier
identifier?
identifier=?
identifier-name
identifier-environment
make-environment
default-environment
environment?
find-identifier
add-identifier!
set-identifier!
macro-objects
compile
eval)))
piclib/library.scm
+4 -3
View File
@@ -91,7 +91,7 @@
(parameterize ((current-library name))
(for-each
(lambda (expr)
(eval expr name)) ; TODO parse library declarations
(eval expr name)) ; TODO parse library declarations
body)))))
(define-transformer 'cond-expand
@@ -215,14 +215,15 @@
and or
cond case else =>
do when unless
parameterize))
parameterize define-record-type))
(export-keyword 'boolean?)
(dictionary-for-each export-keyword (global-objects)))
(set! eval
(let ((e eval))
(lambda (expr . lib)
(let ((lib (if (null? lib) (current-library) (car lib))))
(e expr (library-environment lib))))))
(parameterize ((current-library lib))
(e expr (library-environment lib)))))))
(make-library '(picrin user)))
(values current-library