Fcalva/cyclone
1
0
Fork 0
mirror of https://github.com/justinethier/cyclone.git synced 2025-07-16 17:27:33 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Added local-renamed placeholder

Browse source 
There are complications with just enabling this, though
This commit is contained in:
Justin Ethier 2018-02-08 23:36:38 -05:00
parent 99ca3323b0
commit 5e2df83b2d
1 changed files with 65 additions and 44 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

109
scheme/eval.sld
View file

@ -84,8 +84,8 @@
(define (eval exp . env) (define (eval exp . env)
(define rename-env (env:extend-environment '() '() '())) (define rename-env (env:extend-environment '() '() '()))
(if (null? env) (if (null? env)
((analyze exp *global-environment* rename-env) *global-environment*) ((analyze exp *global-environment* rename-env '()) *global-environment*)
((analyze exp (car env) rename-env) (car env)))) ((analyze exp (car env) rename-env '()) (car env))))
(define (eval-from-c exp . _env) (define (eval-from-c exp . _env)
(let ((env (if (null? _env) *global-environment* (car _env)))) (let ((env (if (null? _env) *global-environment* (car _env))))
@ -384,7 +384,7 @@
;; - exp => Code to analyze ;; - exp => Code to analyze
;; - env => Environment used to expand macros ;; - env => Environment used to expand macros
;; ;;
(define (analyze exp env rename-env) (define (analyze exp env rename-env local-renamed)
;;(newline) ;;(newline)
;;(display "/* ") ;;(display "/* ")
;;(write (list 'analyze exp)) ;;(write (list 'analyze exp))
@ -392,28 +392,28 @@
(cond ((self-evaluating? exp) (cond ((self-evaluating? exp)
(analyze-self-evaluating exp)) (analyze-self-evaluating exp))
((quoted? exp) (analyze-quoted exp)) ((quoted? exp) (analyze-quoted exp))
((variable? exp) (analyze-variable exp)) ((variable? exp) (analyze-variable exp local-renamed))
((and (assignment? exp) ((and (assignment? exp)
(not (null? (cdr exp)))) (not (null? (cdr exp))))
(analyze-assignment exp env rename-env)) (analyze-assignment exp env rename-env local-renamed))
((and (definition? exp) ((and (definition? exp)
(not (null? (cdr exp)))) (not (null? (cdr exp))))
(analyze-definition exp env rename-env)) (analyze-definition exp env rename-env local-renamed))
((and (syntax? exp) ((and (syntax? exp)
(not (null? (cdr exp)))) (not (null? (cdr exp))))
(analyze-syntax exp env)) (analyze-syntax exp env local-renamed))
((and (tagged-list? 'let-syntax exp) ((and (tagged-list? 'let-syntax exp)
(not (null? (cdr exp)))) (not (null? (cdr exp))))
(analyze-let-syntax exp env rename-env)) (analyze-let-syntax exp env rename-env local-renamed))
((and (tagged-list? 'letrec-syntax exp) ((and (tagged-list? 'letrec-syntax exp)
(not (null? (cdr exp)))) (not (null? (cdr exp))))
(analyze-letrec-syntax exp env rename-env)) (analyze-letrec-syntax exp env rename-env local-renamed))
((and (if? exp) ((and (if? exp)
(not (null? (cdr exp)))) (not (null? (cdr exp))))
(analyze-if exp env rename-env)) (analyze-if exp env rename-env local-renamed))
((and (lambda? exp) ((and (lambda? exp)
(not (null? (cdr exp)))) (not (null? (cdr exp))))
(analyze-lambda exp env rename-env)) (analyze-lambda exp env rename-env local-renamed))
((tagged-list? 'import exp) ((tagged-list? 'import exp)
(analyze-import exp env)) (analyze-import exp env))
@ -425,7 +425,7 @@
((procedure? exp) ((procedure? exp)
(lambda (env) exp)) (lambda (env) exp))
((application? exp) (pre-analyze-application exp env rename-env)) ((application? exp) (pre-analyze-application exp env rename-env local-renamed))
(else (else
(error "Unknown expression type -- ANALYZE" exp)))) (error "Unknown expression type -- ANALYZE" exp))))
;(lambda () 'TODO-unknown-exp-type)))) ; JAE - this is a debug line ;(lambda () 'TODO-unknown-exp-type)))) ; JAE - this is a debug line
@ -437,26 +437,32 @@
(let ((qval (cadr exp))) (let ((qval (cadr exp)))
(lambda (env) qval))) (lambda (env) qval)))
(define (analyze-variable exp) (define (analyze-variable exp local-renamed)
(lambda (env) (env:lookup-variable-value exp env))) (lambda (env)
(let ((renamed (assoc exp local-renamed)))
(env:lookup-variable-value
(if renamed
(cdr renamed) ;; Extract renamed symbol
exp)
env))))
(define (analyze-assignment exp a-env rename-env) (define (analyze-assignment exp a-env rename-env local-renamed)
(let ((var (assignment-variable exp)) (let ((var (assignment-variable exp))
(vproc (analyze (assignment-value exp) a-env rename-env))) (vproc (analyze (assignment-value exp) a-env rename-env local-renamed)))
(lambda (env) (lambda (env)
(env:set-variable-value! var (vproc env) env) (env:set-variable-value! var (vproc env) env)
'ok))) 'ok)))
(define (analyze-definition exp a-env rename-env) (define (analyze-definition exp a-env rename-env local-renamed)
(let ((var (definition-variable exp)) (let ((var (definition-variable exp))
(vproc (analyze (definition-value exp) a-env rename-env))) (vproc (analyze (definition-value exp) a-env rename-env local-renamed)))
(lambda (env) (lambda (env)
(env:define-variable! var (vproc env) env) (env:define-variable! var (vproc env) env)
'ok))) 'ok)))
(define (analyze-let-syntax exp a-env rename-env) (define (analyze-let-syntax exp a-env rename-env local-renamed)
(let* (;(rename-env (env:extend-environment '() '() '())) (let* (;(rename-env (env:extend-environment '() '() '()))
(expanded (expand exp a-env rename-env)) (expanded (_expand exp a-env rename-env '() local-renamed))
;(expanded (expand exp (macro:get-env) rename-env)) ;(expanded (expand exp (macro:get-env) rename-env))
(cleaned (macro:cleanup expanded rename-env)) (cleaned (macro:cleanup expanded rename-env))
) )
@ -473,9 +479,9 @@
;(write `(DEBUG env ,a-env)) ;(write `(DEBUG env ,a-env))
;(display "*/ ") ;(display "*/ ")
;(newline) ;(newline)
(analyze cleaned a-env rename-env))) (analyze cleaned a-env rename-env local-renamed)))
(define (analyze-letrec-syntax exp a-env rename-env) (define (analyze-letrec-syntax exp a-env rename-env local-renamed)
(let* (;(rename-env (env:extend-environment '() '() '())) (let* (;(rename-env (env:extend-environment '() '() '()))
;; Build up a macro env ;; Build up a macro env
(vars (foldl (lambda (lis acc) (append acc (car lis))) '() a-env)) (vars (foldl (lambda (lis acc) (append acc (car lis))) '() a-env))
@ -494,7 +500,7 @@
defined-macros) defined-macros)
a-env)) ;(create-environment '() '()))) a-env)) ;(create-environment '() '())))
;; Proceed with macro env ;; Proceed with macro env
(expanded (expand exp macro-env rename-env)) (expanded (_expand exp macro-env rename-env '() local-renamed))
(cleaned (macro:cleanup expanded rename-env)) (cleaned (macro:cleanup expanded rename-env))
) )
;(display "/* ") ;(display "/* ")
@ -503,9 +509,9 @@
;(write `(DEBUG EXPANDED ,cleaned)) ;(write `(DEBUG EXPANDED ,cleaned))
;(display "*/ ") ;(display "*/ ")
;(newline) ;(newline)
(analyze cleaned a-env rename-env))) (analyze cleaned a-env rename-env local-renamed)))
(define (analyze-syntax exp a-env) (define (analyze-syntax exp a-env local-renamed)
(let ((var (cadr exp))) (let ((var (cadr exp)))
(cond (cond
((tagged-list? 'er-macro-transformer (caddr exp)) ;; TODO: need to handle renamed er symbol here?? ((tagged-list? 'er-macro-transformer (caddr exp)) ;; TODO: need to handle renamed er symbol here??
@ -517,7 +523,8 @@
;; Just expand the syntax rules ;; Just expand the syntax rules
;; Possibly want to check the macro system here ;; Possibly want to check the macro system here
(let* ((rename-env (env:extend-environment '() '() '())) (let* ((rename-env (env:extend-environment '() '() '()))
(expanded (expand exp a-env rename-env)) (expanded (_expand exp a-env rename-env '() local-renamed))
;(expanded (expand exp a-env rename-env))
(cleaned (macro:cleanup expanded rename-env))) (cleaned (macro:cleanup expanded rename-env)))
(let ((sproc (make-macro (caddr cleaned)))) (let ((sproc (make-macro (caddr cleaned))))
(lambda (env) (lambda (env)
@ -531,21 +538,33 @@
(apply %import (cdr exp)) (apply %import (cdr exp))
'ok)) 'ok))
(define (analyze-if exp a-env rename-env) (define (analyze-if exp a-env rename-env local-renamed)
(let ((pproc (analyze (if-predicate exp) a-env rename-env)) (let ((pproc (analyze (if-predicate exp) a-env rename-env local-renamed))
(cproc (analyze (if-consequent exp) a-env rename-env)) (cproc (analyze (if-consequent exp) a-env rename-env local-renamed))
(aproc (analyze (if-alternative exp) a-env rename-env))) (aproc (analyze (if-alternative exp) a-env rename-env local-renamed)))
(lambda (env) (lambda (env)
(if (pproc env) (if (pproc env)
(cproc env) (cproc env)
(aproc env))))) (aproc env)))))
(define (analyze-lambda exp a-env rename-env) (define (analyze-lambda exp a-env rename-env local-renamed)
(let ((vars (lambda-parameters exp)) (let* ((vars (lambda-parameters exp))
(bproc (analyze-sequence (lambda-body exp) a-env rename-env))) (args (lambda-formals->list exp))
(a-lookup
(map
(lambda (a)
(let ((a/r (cons a (gensym a))))
a/r))
args))
(bproc (analyze-sequence
(lambda-body exp)
a-env
rename-env
local-renamed ;; TODO: (append a-lookup local-renamed)
)))
(lambda (env) (make-procedure vars bproc env)))) (lambda (env) (make-procedure vars bproc env))))
(define (analyze-sequence exps a-env rename-env) (define (analyze-sequence exps a-env rename-env local-renamed)
(define (sequentially proc1 proc2) (define (sequentially proc1 proc2)
(lambda (env) (proc1 env) (proc2 env))) (lambda (env) (proc1 env) (proc2 env)))
(define (loop first-proc rest-procs) (define (loop first-proc rest-procs)
@ -553,12 +572,12 @@
first-proc first-proc
(loop (sequentially first-proc (car rest-procs)) (loop (sequentially first-proc (car rest-procs))
(cdr rest-procs)))) (cdr rest-procs))))
(let ((procs (map (lambda (e) (analyze e a-env rename-env)) exps))) (let ((procs (map (lambda (e) (analyze e a-env rename-env local-renamed)) exps)))
(if (null? procs) (if (null? procs)
(error "Empty sequence -- ANALYZE")) (error "Empty sequence -- ANALYZE"))
(loop (car procs) (cdr procs)))) (loop (car procs) (cdr procs))))
(define (pre-analyze-application exp a-env rename-env) (define (pre-analyze-application exp a-env rename-env local-renamed)
;; Notes: ;; Notes:
;; look up symbol in env, and expand if it is a macro ;; look up symbol in env, and expand if it is a macro
;; Adds some extra overhead into eval, which is not ideal. may need to ;; Adds some extra overhead into eval, which is not ideal. may need to
@ -575,7 +594,7 @@
(if (Cyc-macro? macro-op) (if (Cyc-macro? macro-op)
;; Compiled macro, call directly ;; Compiled macro, call directly
(let ((expanded (let ((expanded
(macro:expand exp (list 'macro macro-op) a-env rename-env '()) (macro:expand exp (list 'macro macro-op) a-env rename-env local-renamed)
;(apply macro-op ;(apply macro-op
; (list (cons (car exp) (operands exp)) ; (list (cons (car exp) (operands exp))
; (Cyc-er-rename rename-env a-env '()) ; (Cyc-er-rename rename-env a-env '())
@ -589,7 +608,8 @@
;(newline) ;(newline)
(analyze expanded (analyze expanded
a-env a-env
rename-env)) rename-env
local-renamed))
;; Interpreted macro, build expression and eval ;; Interpreted macro, build expression and eval
(let* (;(expr (cons macro-op (let* (;(expr (cons macro-op
; (list (cons 'quote ; (list (cons 'quote
@ -598,7 +618,7 @@
; (Cyc-er-rename rename-env a-env '()) ; (Cyc-er-rename rename-env a-env '())
; (Cyc-er-compare? rename-env a-env)))) ; (Cyc-er-compare? rename-env a-env))))
; (expanded (eval expr a-env)) ;; Expand macro ; (expanded (eval expr a-env)) ;; Expand macro
(expanded (macro:expand exp (list 'macro macro-op) a-env rename-env '())) (expanded (macro:expand exp (list 'macro macro-op) a-env rename-env local-renamed))
) )
;(display "/* ") ;(display "/* ")
;(write `(DEBUG expand ,exp)) ;(write `(DEBUG expand ,exp))
@ -609,7 +629,8 @@
(analyze (analyze
expanded expanded
a-env a-env
rename-env)))))) rename-env
local-renamed))))))
(cond (cond
;; compiled macro ;; compiled macro
((Cyc-macro? var) ((Cyc-macro? var)
@ -623,12 +644,12 @@
(expand (cdr op))) (expand (cdr op)))
;; normal function ;; normal function
(else (else
(analyze-application exp a-env rename-env))))) (analyze-application exp a-env rename-env local-renamed)))))
(define (analyze-application exp a-env rename-env) (define (analyze-application exp a-env rename-env local-renamed)
(let ((fproc (analyze (operator exp) a-env rename-env)) (let ((fproc (analyze (operator exp) a-env rename-env local-renamed))
(aprocs (map (lambda (o) (aprocs (map (lambda (o)
(analyze o a-env rename-env)) (analyze o a-env rename-env local-renamed))
(operands exp)))) (operands exp))))
(lambda (env) (lambda (env)
(execute-application (fproc env) (execute-application (fproc env)