mirror of
https://github.com/justinethier/cyclone.git
synced 2025-05-24 04:25:06 +02:00
Relocating code
This commit is contained in:
Justin Ethier
parent
eac413a2f5
commit
c5271f05fe
2 changed files with 142 additions and 140 deletions
|
|
@ -13,148 +13,8 @@
|
||||||
(scheme cyclone util)
|
(scheme cyclone util)
|
||||||
)
|
)
|
||||||
(export
|
(export
|
||||||
macro:macro?
|
|
||||||
macro:expand
|
|
||||||
macro:add!
|
|
||||||
macro:cleanup
|
|
||||||
macro:load-env!
|
|
||||||
macro:get-env
|
|
||||||
macro:get-defined-macros
|
|
||||||
)
|
)
|
||||||
(inline
|
(inline
|
||||||
macro:macro?)
|
macro:macro?)
|
||||||
(begin
|
(begin
|
||||||
;; top-level macro environment
|
|
||||||
(define *macro:env* '())
|
|
||||||
|
|
||||||
;; A list of all macros defined by the program/library being compiled
|
|
||||||
(define *macro:defined-macros* '())
|
|
||||||
|
|
||||||
(define (macro:add! name body)
|
|
||||||
(set! *macro:defined-macros*
|
|
||||||
(cons (cons name body) *macro:defined-macros*))
|
|
||||||
#t)
|
|
||||||
|
|
||||||
(define (macro:load-env! defined-macros base-env)
|
|
||||||
(set! *macro:env* (env:extend-environment
|
|
||||||
(map car defined-macros)
|
|
||||||
(map (lambda (v)
|
|
||||||
(list 'macro (cdr v)))
|
|
||||||
defined-macros)
|
|
||||||
base-env)))
|
|
||||||
|
|
||||||
(define (macro:get-env) *macro:env*)
|
|
||||||
|
|
||||||
(define (macro:get-defined-macros) *macro:defined-macros*)
|
|
||||||
|
|
||||||
;; Macro section
|
|
||||||
(define (macro:macro? exp defined-macros) (assoc (car exp) defined-macros))
|
|
||||||
|
|
||||||
(define (macro:expand exp macro mac-env rename-env)
|
|
||||||
(let* ((use-env (env:extend-environment '() '() '()))
|
|
||||||
(compiled-macro? (or (Cyc-macro? (Cyc-get-cvar (cadr macro)))
|
|
||||||
(procedure? (cadr macro))))
|
|
||||||
(result #f))
|
|
||||||
;(newline)
|
|
||||||
;(display "/* ")
|
|
||||||
;(display (list 'macro:expand exp macro compiled-macro?))
|
|
||||||
;(display "*/ ")
|
|
||||||
|
|
||||||
;; Invoke ER macro
|
|
||||||
(set! result
|
|
||||||
(cond
|
|
||||||
((not macro)
|
|
||||||
(error "macro not found" exp))
|
|
||||||
(compiled-macro?
|
|
||||||
((Cyc-get-cvar (cadr macro))
|
|
||||||
exp
|
|
||||||
(Cyc-er-rename use-env mac-env)
|
|
||||||
(Cyc-er-compare? use-env rename-env)))
|
|
||||||
(else
|
|
||||||
(eval
|
|
||||||
(list
|
|
||||||
(Cyc-get-cvar (cadr macro))
|
|
||||||
(list 'quote exp)
|
|
||||||
(Cyc-er-rename use-env mac-env)
|
|
||||||
(Cyc-er-compare? use-env rename-env))
|
|
||||||
mac-env))))
|
|
||||||
; (newline)
|
|
||||||
; (display "/* ")
|
|
||||||
; (display (list 'macro:expand exp macro compiled-macro?))
|
|
||||||
; (newline)
|
|
||||||
; (display (list result))
|
|
||||||
; (display "*/ ")
|
|
||||||
(macro:add-renamed-vars! use-env rename-env)
|
|
||||||
result))
|
|
||||||
|
|
||||||
(define (macro:add-renamed-vars! env renamed-env)
|
|
||||||
(let ((frame (env:first-frame renamed-env)))
|
|
||||||
(for-each
|
|
||||||
(lambda (var val)
|
|
||||||
(env:add-binding-to-frame! var val frame))
|
|
||||||
(env:all-variables env)
|
|
||||||
(env:all-values env))))
|
|
||||||
|
|
||||||
(define (macro:cleanup expr rename-env)
|
|
||||||
(define (clean expr bv) ;; Bound variables
|
|
||||||
;(newline)
|
|
||||||
;(display "/* macro:cleanup->clean, bv =")
|
|
||||||
;(write bv)
|
|
||||||
;(newline)
|
|
||||||
;(write expr)
|
|
||||||
;(newline)
|
|
||||||
;(display "*/ ")
|
|
||||||
(cond
|
|
||||||
((const? expr) expr)
|
|
||||||
((null? expr) expr)
|
|
||||||
((quote? expr)
|
|
||||||
(let ((atom (cadr expr)))
|
|
||||||
;; Clean up any renamed symbols that are quoted
|
|
||||||
;; TODO: good enough for quoted pairs or do
|
|
||||||
;; we need to traverse those, too?
|
|
||||||
(if (ref? atom)
|
|
||||||
`(quote ,(clean atom bv))
|
|
||||||
expr)))
|
|
||||||
((define-c? expr) expr)
|
|
||||||
((ref? expr)
|
|
||||||
;; if symbol has been renamed and is not a bound variable,
|
|
||||||
;; undo the rename
|
|
||||||
(let ((val (env:lookup expr rename-env #f)))
|
|
||||||
(if (and val (not (member expr bv)))
|
|
||||||
(clean val bv)
|
|
||||||
expr)))
|
|
||||||
((if-syntax? expr)
|
|
||||||
`(if ,(clean (if->condition expr) bv)
|
|
||||||
,(clean (if->then expr) bv)
|
|
||||||
,(if (if-else? expr)
|
|
||||||
(clean (if->else expr) bv)
|
|
||||||
#f)))
|
|
||||||
((lambda? expr)
|
|
||||||
`(lambda ,(lambda->formals expr)
|
|
||||||
,@(map (lambda (e)
|
|
||||||
(clean e (append
|
|
||||||
(lambda-formals->list expr)
|
|
||||||
bv)))
|
|
||||||
(lambda->exp expr))))
|
|
||||||
;; At this point defines cannot be in lambda form.
|
|
||||||
;; EG: (define (f x) ...)
|
|
||||||
((define? expr)
|
|
||||||
(let ((bv* (cons (define->var expr) bv)))
|
|
||||||
`(define ,(define->var expr)
|
|
||||||
,@(map
|
|
||||||
(lambda (e) (clean e bv*))
|
|
||||||
(define->exp expr)))))
|
|
||||||
;; For now, assume set is not introducing a new binding
|
|
||||||
((set!? expr)
|
|
||||||
`(set! ,(clean (set!->var expr) bv)
|
|
||||||
,(clean (set!->exp expr) bv)))
|
|
||||||
((app? expr)
|
|
||||||
(map (lambda (e) (clean e bv))
|
|
||||||
expr))
|
|
||||||
(else
|
|
||||||
(error "macro cleanup unexpected expression: " expr))))
|
|
||||||
(clean expr '()))
|
|
||||||
|
|
||||||
; TODO: get macro name, transformer
|
|
||||||
; TODO: let-syntax forms
|
|
||||||
))
|
))
|
||||||
|
|
|
||||||
142
scheme/eval.sld
142
scheme/eval.sld
|
|
@ -25,6 +25,13 @@
|
||||||
%import
|
%import
|
||||||
imported?
|
imported?
|
||||||
%set-import-dirs!
|
%set-import-dirs!
|
||||||
|
macro:macro?
|
||||||
|
macro:expand
|
||||||
|
macro:add!
|
||||||
|
macro:cleanup
|
||||||
|
macro:load-env!
|
||||||
|
macro:get-env
|
||||||
|
macro:get-defined-macros
|
||||||
)
|
)
|
||||||
(inline
|
(inline
|
||||||
primitive-implementation
|
primitive-implementation
|
||||||
|
|
@ -43,6 +50,7 @@
|
||||||
assignment-value
|
assignment-value
|
||||||
assignment-variable
|
assignment-variable
|
||||||
variable?
|
variable?
|
||||||
|
macro:macro?
|
||||||
)
|
)
|
||||||
(begin
|
(begin
|
||||||
|
|
||||||
|
|
@ -663,4 +671,138 @@
|
||||||
" Cyc_check_str(data, name);
|
" Cyc_check_str(data, name);
|
||||||
return_closcall1(data, k, is_library_loaded(string_str(name))); ")
|
return_closcall1(data, k, is_library_loaded(string_str(name))); ")
|
||||||
|
|
||||||
|
;; Macro section
|
||||||
|
;; top-level macro environment
|
||||||
|
(define *macro:env* '())
|
||||||
|
|
||||||
|
;; A list of all macros defined by the program/library being compiled
|
||||||
|
(define *macro:defined-macros* '())
|
||||||
|
|
||||||
|
(define (macro:add! name body)
|
||||||
|
(set! *macro:defined-macros*
|
||||||
|
(cons (cons name body) *macro:defined-macros*))
|
||||||
|
#t)
|
||||||
|
|
||||||
|
(define (macro:load-env! defined-macros base-env)
|
||||||
|
(set! *macro:env* (env:extend-environment
|
||||||
|
(map car defined-macros)
|
||||||
|
(map (lambda (v)
|
||||||
|
(list 'macro (cdr v)))
|
||||||
|
defined-macros)
|
||||||
|
base-env)))
|
||||||
|
|
||||||
|
(define (macro:get-env) *macro:env*)
|
||||||
|
|
||||||
|
(define (macro:get-defined-macros) *macro:defined-macros*)
|
||||||
|
|
||||||
|
;; Macro section
|
||||||
|
(define (macro:macro? exp defined-macros) (assoc (car exp) defined-macros))
|
||||||
|
|
||||||
|
(define (macro:expand exp macro mac-env rename-env)
|
||||||
|
(let* ((use-env (env:extend-environment '() '() '()))
|
||||||
|
(compiled-macro? (or (Cyc-macro? (Cyc-get-cvar (cadr macro)))
|
||||||
|
(procedure? (cadr macro))))
|
||||||
|
(result #f))
|
||||||
|
;(newline)
|
||||||
|
;(display "/* ")
|
||||||
|
;(display (list 'macro:expand exp macro compiled-macro?))
|
||||||
|
;(display "*/ ")
|
||||||
|
|
||||||
|
;; Invoke ER macro
|
||||||
|
(set! result
|
||||||
|
(cond
|
||||||
|
((not macro)
|
||||||
|
(error "macro not found" exp))
|
||||||
|
(compiled-macro?
|
||||||
|
((Cyc-get-cvar (cadr macro))
|
||||||
|
exp
|
||||||
|
(Cyc-er-rename use-env mac-env)
|
||||||
|
(Cyc-er-compare? use-env rename-env)))
|
||||||
|
(else
|
||||||
|
(eval
|
||||||
|
(list
|
||||||
|
(Cyc-get-cvar (cadr macro))
|
||||||
|
(list 'quote exp)
|
||||||
|
(Cyc-er-rename use-env mac-env)
|
||||||
|
(Cyc-er-compare? use-env rename-env))
|
||||||
|
mac-env))))
|
||||||
|
; (newline)
|
||||||
|
; (display "/* ")
|
||||||
|
; (display (list 'macro:expand exp macro compiled-macro?))
|
||||||
|
; (newline)
|
||||||
|
; (display (list result))
|
||||||
|
; (display "*/ ")
|
||||||
|
(macro:add-renamed-vars! use-env rename-env)
|
||||||
|
result))
|
||||||
|
|
||||||
|
(define (macro:add-renamed-vars! env renamed-env)
|
||||||
|
(let ((frame (env:first-frame renamed-env)))
|
||||||
|
(for-each
|
||||||
|
(lambda (var val)
|
||||||
|
(env:add-binding-to-frame! var val frame))
|
||||||
|
(env:all-variables env)
|
||||||
|
(env:all-values env))))
|
||||||
|
|
||||||
|
(define (macro:cleanup expr rename-env)
|
||||||
|
(define (clean expr bv) ;; Bound variables
|
||||||
|
;(newline)
|
||||||
|
;(display "/* macro:cleanup->clean, bv =")
|
||||||
|
;(write bv)
|
||||||
|
;(newline)
|
||||||
|
;(write expr)
|
||||||
|
;(newline)
|
||||||
|
;(display "*/ ")
|
||||||
|
(cond
|
||||||
|
((const? expr) expr)
|
||||||
|
((null? expr) expr)
|
||||||
|
((quote? expr)
|
||||||
|
(let ((atom (cadr expr)))
|
||||||
|
;; Clean up any renamed symbols that are quoted
|
||||||
|
;; TODO: good enough for quoted pairs or do
|
||||||
|
;; we need to traverse those, too?
|
||||||
|
(if (ref? atom)
|
||||||
|
`(quote ,(clean atom bv))
|
||||||
|
expr)))
|
||||||
|
((define-c? expr) expr)
|
||||||
|
((ref? expr)
|
||||||
|
;; if symbol has been renamed and is not a bound variable,
|
||||||
|
;; undo the rename
|
||||||
|
(let ((val (env:lookup expr rename-env #f)))
|
||||||
|
(if (and val (not (member expr bv)))
|
||||||
|
(clean val bv)
|
||||||
|
expr)))
|
||||||
|
((if-syntax? expr)
|
||||||
|
`(if ,(clean (if->condition expr) bv)
|
||||||
|
,(clean (if->then expr) bv)
|
||||||
|
,(if (if-else? expr)
|
||||||
|
(clean (if->else expr) bv)
|
||||||
|
#f)))
|
||||||
|
((lambda? expr)
|
||||||
|
`(lambda ,(lambda->formals expr)
|
||||||
|
,@(map (lambda (e)
|
||||||
|
(clean e (append
|
||||||
|
(lambda-formals->list expr)
|
||||||
|
bv)))
|
||||||
|
(lambda->exp expr))))
|
||||||
|
;; At this point defines cannot be in lambda form.
|
||||||
|
;; EG: (define (f x) ...)
|
||||||
|
((define? expr)
|
||||||
|
(let ((bv* (cons (define->var expr) bv)))
|
||||||
|
`(define ,(define->var expr)
|
||||||
|
,@(map
|
||||||
|
(lambda (e) (clean e bv*))
|
||||||
|
(define->exp expr)))))
|
||||||
|
;; For now, assume set is not introducing a new binding
|
||||||
|
((set!? expr)
|
||||||
|
`(set! ,(clean (set!->var expr) bv)
|
||||||
|
,(clean (set!->exp expr) bv)))
|
||||||
|
((app? expr)
|
||||||
|
(map (lambda (e) (clean e bv))
|
||||||
|
expr))
|
||||||
|
(else
|
||||||
|
(error "macro cleanup unexpected expression: " expr))))
|
||||||
|
(clean expr '()))
|
||||||
|
|
||||||
|
; TODO: get macro name, transformer
|
||||||
|
; TODO: let-syntax forms
|
||||||
))
|
))
|
||||||
|
|
|
||||||
Loading…
Add table
Reference in a new issue