Fcalva/cyclone
1
0
Fork 0
mirror of https://github.com/justinethier/cyclone.git synced 2025-05-23 20:15:05 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

WIP

Browse source
This commit is contained in:
Justin Ethier 2018-01-17 17:50:45 -05:00
parent 32361ddced
commit 435fefe6d0
2 changed files with 19 additions and 16 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

13
scheme/cyclone/util.sld
View file

@ -614,14 +614,16 @@
;;; Explicit renaming macros ;;; Explicit renaming macros
(define (Cyc-er-rename use-env mac-env) (define (Cyc-er-rename use-env mac-env binding-lis)
((lambda (renames) ((lambda (renames)
(lambda (identifier) (lambda (identifier)
;(Cyc-write `(ER rename ,identifier) (current-output-port)) ;(Cyc-write `(ER rename ,identifier) (current-output-port))
;(Cyc-display "\n" (current-output-port)) ;(Cyc-display "\n" (current-output-port))
((lambda (cell) ((lambda (binding-cell cell)
(if cell (cond
(cdr cell) (binding-cell (cdr binding-cell))
(cell (cdr cell))
(else
((lambda (name) ((lambda (name)
(set! renames (cons (cons identifier name) renames)) (set! renames (cons (cons identifier name) renames))
name) name)
@ -654,7 +656,8 @@
; forms other than symbols, if that is done. ; forms other than symbols, if that is done.
; ;
;(make-syntactic-closure mac-env '() identifier) ;(make-syntactic-closure mac-env '() identifier)
))) ))))
(assq identifier binding-lis)
(assq identifier renames)) (assq identifier renames))
)) ))
;; TODO: For now, do not allow renaming of special form symbols to ;; TODO: For now, do not allow renaming of special form symbols to

22
scheme/eval.sld
View file

@ -563,7 +563,7 @@
;; Compiled macro, call directly ;; Compiled macro, call directly
(analyze (apply macro-op (analyze (apply macro-op
(list (cons (car exp) (operands exp)) (list (cons (car exp) (operands exp))
(Cyc-er-rename use-env a-env) (Cyc-er-rename use-env a-env '())
(Cyc-er-compare? use-env use-env))) (Cyc-er-compare? use-env use-env)))
a-env) a-env)
;; Interpreted macro, build expression and eval ;; Interpreted macro, build expression and eval
@ -571,7 +571,7 @@
(list (cons 'quote (list (cons 'quote
(list (cons (car exp) (list (cons (car exp)
(operands exp)))) (operands exp))))
(Cyc-er-rename use-env a-env) (Cyc-er-rename use-env a-env '())
(Cyc-er-compare? use-env use-env))))) (Cyc-er-compare? use-env use-env)))))
(analyze (analyze
(eval expr a-env) ;; Expand macro (eval expr a-env) ;; Expand macro
@ -746,7 +746,7 @@
;; Macro section ;; Macro section
(define (macro:macro? exp defined-macros) (assoc (car exp) defined-macros)) (define (macro:macro? exp defined-macros) (assoc (car exp) defined-macros))
(define (macro:expand exp macro mac-env rename-env) (define (macro:expand exp macro mac-env rename-env local-renamed)
(let* ((use-env (env:extend-environment '() '() '())) (let* ((use-env (env:extend-environment '() '() '()))
(compiled-macro? (or (Cyc-macro? (Cyc-get-cvar (cadr macro))) (compiled-macro? (or (Cyc-macro? (Cyc-get-cvar (cadr macro)))
(procedure? (cadr macro)))) (procedure? (cadr macro))))
@ -764,14 +764,14 @@
(compiled-macro? (compiled-macro?
((Cyc-get-cvar (cadr macro)) ((Cyc-get-cvar (cadr macro))
exp exp
(Cyc-er-rename use-env mac-env) (Cyc-er-rename use-env mac-env local-renamed)
(Cyc-er-compare? use-env rename-env))) (Cyc-er-compare? use-env rename-env)))
(else (else
(eval (eval
(list (list
(Cyc-get-cvar (cadr macro)) (Cyc-get-cvar (cadr macro))
(list 'quote exp) (list 'quote exp)
(Cyc-er-rename use-env mac-env) (Cyc-er-rename use-env mac-env local-renamed)
(Cyc-er-compare? use-env rename-env)) (Cyc-er-compare? use-env rename-env))
mac-env)))) mac-env))))
; (newline) ; (newline)
@ -905,9 +905,9 @@
(map (map
(lambda (a) (lambda (a)
(let ((a/r (cons a (gensym a)))) (let ((a/r (cons a (gensym a))))
I think we want to pass these a-lookup bindings to Cyc-er-rename and ; I think we want to pass these a-lookup bindings to Cyc-er-rename and
use them to rename any locals. ideally want this stored with macro def ; use them to rename any locals. ideally want this stored with macro def
for define-syntax. I think we get it for free with let*-syntax ; for define-syntax. I think we get it for free with let*-syntax
;; TODO: define needed? ;; TODO: define needed?
;(env:define-variable! (cdr a/r) (car a/r) rename-env) ;(env:define-variable! (cdr a/r) (car a/r) rename-env)
a/r)) a/r))
@ -1050,13 +1050,13 @@
(cond (cond
((tagged-list? 'macro val) ((tagged-list? 'macro val)
(_expand ; Could expand into another macro (_expand ; Could expand into another macro
(macro:expand exp val env rename-env) (macro:expand exp val env rename-env local-renamed)
env env
rename-env rename-env
local-env local-renamed)) local-env local-renamed))
((Cyc-macro? val) ((Cyc-macro? val)
(_expand ; Could expand into another macro (_expand ; Could expand into another macro
(macro:expand exp (list 'macro val) env rename-env) (macro:expand exp (list 'macro val) env rename-env local-renamed)
env env
rename-env rename-env
local-env local-renamed)) local-env local-renamed))
@ -1181,7 +1181,7 @@
(if (tagged-list? 'macro val) (if (tagged-list? 'macro val)
;; Expand macro here so we can catch begins in the expanded code, ;; Expand macro here so we can catch begins in the expanded code,
;; including nested begins ;; including nested begins
(let ((expanded (macro:expand this-exp val env rename-env))) (let ((expanded (macro:expand this-exp val env rename-env local-renamed)))
;(log `(DONE WITH macro:expand)) ;(log `(DONE WITH macro:expand))
(_expand-body (_expand-body
result result