diff --git a/CHANGELOG.md b/CHANGELOG.md index 2228da42..e435cbc5 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,16 @@ ## 0.7.1 - TBD +Features + +- Added `let-syntax` and `letrec-syntax` to the compiler and interpreter. +- Added the `(scheme repl)` library and `interaction-environment` function from R7RS. +- Allow `eval` to recognize `syntax-rules` macros. + +Internal Changes + +- Relocated all macro expansion code to the `(scheme eval)` module. Cyclone's `(scheme cyclone macros)` library is now obsolete. + ## 0.7 - November 17, 2017 Features diff --git a/Makefile b/Makefile index d5c974cf..36db4a6c 100644 --- a/Makefile +++ b/Makefile @@ -206,6 +206,7 @@ bootstrap : icyc libs cp scheme/char.c $(BOOTSTRAP_DIR)/scheme cp scheme/complex.c $(BOOTSTRAP_DIR)/scheme cp scheme/eval.c $(BOOTSTRAP_DIR)/scheme + cp scheme/repl.c $(BOOTSTRAP_DIR)/scheme cp scheme/file.c $(BOOTSTRAP_DIR)/scheme cp scheme/inexact.c $(BOOTSTRAP_DIR)/scheme cp scheme/lazy.c $(BOOTSTRAP_DIR)/scheme diff --git a/Makefile.config b/Makefile.config index 55bdac0b..e405deaf 100644 --- a/Makefile.config +++ b/Makefile.config @@ -52,7 +52,7 @@ RM ?= rm -f #LN ?= ln INSTALL ?= install MKDIR ?= $(INSTALL) -d -RMDIR ?= rmdir +RMDIR ?= rm -rf PREFIX ?= /usr/local BINDIR ?= $(PREFIX)/bin diff --git a/cyclone.scm b/cyclone.scm index 68fdc262..e35e2480 100644 --- a/cyclone.scm +++ b/cyclone.scm @@ -20,7 +20,6 @@ (scheme cyclone primitives) (scheme cyclone transforms) (scheme cyclone cps-optimizations) - (scheme cyclone macros) (scheme cyclone libraries)) (define *optimization-level* 2) ;; Default level diff --git a/runtime.c b/runtime.c index c2d379cb..a163cd87 100644 --- a/runtime.c +++ b/runtime.c @@ -4208,8 +4208,8 @@ void _symbol_127(void *data, object cont, object args) void _Cyc_91get_91cvar(void *data, object cont, object args) { - printf("not implemented\n"); - exit(1); + Cyc_check_num_args(data, "Cyc-get-cvar", 1, args); + return_closcall1(data, cont, Cyc_get_cvar((car(args)))); } void _Cyc_91set_91cvar_67(void *data, object cont, object args) diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index d3456d11..84b207cf 100644 --- a/scheme/cyclone/cgen.sld +++ b/scheme/cyclone/cgen.sld @@ -9,6 +9,7 @@ (define-library (scheme cyclone cgen) (import (scheme base) (scheme char) + (scheme eval) (scheme inexact) (scheme write) (scheme cyclone primitives) diff --git a/scheme/cyclone/macros.sld b/scheme/cyclone/macros.sld index 1696248e..c09751ba 100644 --- a/scheme/cyclone/macros.sld +++ b/scheme/cyclone/macros.sld @@ -13,152 +13,8 @@ (scheme cyclone util) ) (export - define-syntax? - macro:macro? - macro:expand - macro:add! - macro:cleanup - macro:load-env! - macro:get-env - macro:get-defined-macros ) (inline macro:macro?) (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 (define-syntax? exp) - (tagged-list? 'define-syntax exp)) - - (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 )) diff --git a/scheme/cyclone/transforms.sld b/scheme/cyclone/transforms.sld index bb6cbd60..1153a351 100644 --- a/scheme/cyclone/transforms.sld +++ b/scheme/cyclone/transforms.sld @@ -18,18 +18,15 @@ (scheme cyclone ast) (scheme cyclone common) (scheme cyclone libraries) - (scheme cyclone macros) (scheme cyclone primitives) (scheme cyclone pretty-print) (scheme cyclone util) (srfi 69) ) (export - *defined-macros* *do-code-gen* *trace-level* *primitives* - get-macros built-in-syms trace trace:error @@ -67,8 +64,6 @@ app->args precompute-prim-app? begin->exps - define-lambda? - define->lambda closure? closure->lam closure->env @@ -88,8 +83,6 @@ cell->value cell-get? cell-get->cell - expand - expand-lambda-body isolate-globals has-global? global-vars @@ -127,10 +120,6 @@ ) (begin -;; Container for built-in macros -(define (get-macros) *defined-macros*) -(define *defined-macros* (list)) - (define (built-in-syms) '(call/cc define)) @@ -411,26 +400,6 @@ (define (begin->exps exp) (cdr exp)) -(define (define-lambda? exp) - (let ((var (cadr exp))) - (or - ;; Standard function - (and (list? var) - (> (length var) 0) - (symbol? (car var))) - ;; Varargs function - (and (pair? var) - (symbol? (car var)))))) - -(define (define->lambda exp) - (cond - ((define-lambda? exp) - (let ((var (caadr exp)) - (args (cdadr exp)) - (body (cddr exp))) - `(define ,var (lambda ,args ,@body)))) - (else exp))) - ; closure? : exp -> boolean (define (closure? exp) (tagged-list? 'closure exp)) @@ -506,199 +475,6 @@ (define (cell-get->cell exp) (cadr exp)) - -;; Macro expansion - -;TODO: modify this whole section to use macros:get-env instead of *defined-macros*. macro:get-env becomes the mac-env. any new scopes need to extend that env, and an env parameter needs to be added to (expand). any macros defined with define-syntax use that env as their mac-env (how to store that)? -; expand : exp -> exp -(define (expand exp env rename-env) - (define (log e) - (display - (list 'expand e 'env - (env:frame-variables (env:first-frame env))) - (current-error-port)) - (newline (current-error-port))) - ;(log exp) - ;(trace:error `(expand ,exp)) - (cond - ((const? exp) exp) - ((prim? exp) exp) - ((ref? exp) exp) - ((quote? exp) exp) - ((lambda? exp) `(lambda ,(lambda->formals exp) - ,@(expand-body '() (lambda->exp exp) env rename-env) - ;,@(map - ; ;; TODO: use extend env here? - ; (lambda (expr) (expand expr env rename-env)) - ; (lambda->exp exp)) - )) - ((define? exp) (if (define-lambda? exp) - (expand (define->lambda exp) env rename-env) - `(define ,(expand (define->var exp) env rename-env) - ,@(expand (define->exp exp) env rename-env)))) - ((set!? exp) `(set! ,(expand (set!->var exp) env rename-env) - ,(expand (set!->exp exp) env rename-env))) - ((if-syntax? exp) `(if ,(expand (if->condition exp) env rename-env) - ,(expand (if->then exp) env rename-env) - ,(if (if-else? exp) - (expand (if->else exp) env rename-env) - ;; Insert default value for missing else clause - ;; FUTURE: append the empty (unprinted) value - ;; instead of #f - #f))) - ((define-c? exp) exp) - ((define-syntax? exp) - ;(trace:info `(define-syntax ,exp)) - (let* ((name (cadr exp)) - (trans (caddr exp)) - (body (cadr trans))) - (cond - ((tagged-list? 'syntax-rules trans) ;; TODO: what if syntax-rules is renamed? - (expand - `(define-syntax ,name ,(expand trans env rename-env)) - env rename-env)) - (else - ;; TODO: for now, do not let a compiled macro be re-defined. - ;; this is a hack for performance compiling (scheme base) - (let ((macro (env:lookup name env #f))) - (cond - ((and (tagged-list? 'macro macro) - (or (Cyc-macro? (Cyc-get-cvar (cadr macro))) - (procedure? (cadr macro)))) - (trace:info `(DEBUG compiled macro ,name do not redefine))) - (else - ;; Use this to keep track of macros for filtering unused defines - (set! *defined-macros* (cons (cons name body) *defined-macros*)) - ;; Keep track of macros added during compilation. - ;; TODO: why in both places? - (macro:add! name body) - (env:define-variable! name (list 'macro body) env))) - ;; Keep as a 'define' form so available at runtime - ;; TODO: may run into issues with expanding now, before some - ;; of the macros are defined. may need to make a special pass - ;; to do loading or expansion of macro bodies - `(define ,name ,(expand body env rename-env))))))) - ((app? exp) - (cond - ((symbol? (car exp)) - (let ((val (env:lookup (car exp) env #f))) - (if (tagged-list? 'macro val) - (expand ; Could expand into another macro - (macro:expand exp val env rename-env) - env rename-env) - (map - (lambda (expr) (expand expr env rename-env)) - exp)))) - (else - ;; TODO: note that map does not guarantee that expressions are - ;; evaluated in order. For example, the list might be processed - ;; in reverse order. Might be better to use a fold here and - ;; elsewhere in (expand). - (map - (lambda (expr) (expand expr env rename-env)) - exp)))) - (else - (error "unknown exp: " exp)))) - -;; Nicer interface to expand-body -(define (expand-lambda-body exp env rename-env) - (expand-body '() exp env rename-env)) - -;; Helper to expand a lambda body, so we can splice in any begin's -(define (expand-body result exp env rename-env) - (define (log e) - (display (list 'expand-body e 'env - (env:frame-variables (env:first-frame env))) - (current-error-port)) - (newline (current-error-port))) - - (if (null? exp) - (reverse result) - (let ((this-exp (car exp))) -;(display (list 'expand-body this-exp) (current-error-port)) -;(newline (current-error-port)) - (cond - ((or (const? this-exp) - (prim? this-exp) - (ref? this-exp) - (quote? this-exp) - (define-c? this-exp)) -;(log this-exp) - (expand-body (cons this-exp result) (cdr exp) env rename-env)) - ((define? this-exp) -;(log this-exp) - (expand-body - (cons - (expand this-exp env rename-env) - result) - (cdr exp) - env - rename-env)) - ((or (define-syntax? this-exp) - (lambda? this-exp) - (set!? this-exp) - (if? this-exp)) -;(log (car this-exp)) - (expand-body - (cons - (expand this-exp env rename-env) - result) - (cdr exp) - env - rename-env)) - ;; Splice in begin contents and keep expanding body - ((begin? this-exp) - (let* ((expr this-exp) - (begin-exprs (begin->exps expr))) -;(log (car this-exp)) - (expand-body - result - (append begin-exprs (cdr exp)) - env - rename-env))) - ((app? this-exp) - (cond - ((symbol? (caar exp)) -;(log (car this-exp)) - (let ((val (env:lookup (caar exp) env #f))) -;(log `(DONE WITH env:lookup ,(caar exp) ,val ,(tagged-list? 'macro val))) - (if (tagged-list? 'macro val) - ;; Expand macro here so we can catch begins in the expanded code, - ;; including nested begins - (let ((expanded (macro:expand this-exp val env rename-env))) -;(log `(DONE WITH macro:expand)) - (expand-body - result - (cons - expanded ;(macro:expand this-exp val env) - (cdr exp)) - env - rename-env)) - ;; No macro, use main expand function to process - (expand-body - (cons - (map - (lambda (expr) (expand expr env rename-env)) - this-exp) - result) - (cdr exp) - env - rename-env)))) - (else -;(log 'app) - (expand-body - (cons - (map - (lambda (expr) (expand expr env rename-env)) - this-exp) - result) - (cdr exp) - env - rename-env)))) - (else - (error "unknown exp: " this-exp)))))) - - ;; Top-level analysis ; Separate top-level defines (globals) from other expressions diff --git a/scheme/cyclone/util.sld b/scheme/cyclone/util.sld index 7fa9050b..984d3ceb 100644 --- a/scheme/cyclone/util.sld +++ b/scheme/cyclone/util.sld @@ -11,12 +11,17 @@ (scheme char)) (export ;; Code analysis + define-syntax? + let-syntax? + letrec-syntax? tagged-list? if? if-syntax? begin? lambda? pair->list + define-lambda? + define->lambda formals->list lambda-formals->list lambda-varargs? @@ -120,7 +125,15 @@ (or (= (length exp) 3) (= (length exp) 4)))) - + +(define (define-syntax? exp) + (tagged-list? 'define-syntax exp)) + +(define (let-syntax? exp) + (tagged-list? 'let-syntax exp)) + +(define (letrec-syntax? exp) + (tagged-list? 'letrec-syntax exp)) ; begin? : exp -> boolean (define (begin? exp) @@ -239,6 +252,26 @@ (cons lst '()) (cons (car lst) (loop (cdr lst)))))) +(define (define-lambda? exp) + (let ((var (cadr exp))) + (or + ;; Standard function + (and (list? var) + (> (length var) 0) + (symbol? (car var))) + ;; Varargs function + (and (pair? var) + (symbol? (car var)))))) + +(define (define->lambda exp) + (cond + ((define-lambda? exp) + (let ((var (caadr exp)) + (args (cdadr exp)) + (body (cddr exp))) + `(define ,var (lambda ,args ,@body)))) + (else exp))) + ; lambda->formals : lambda-exp -> list[symbol] (define (lambda->formals exp) (cadr exp)) @@ -629,6 +662,8 @@ '( (define . define) (define-syntax . define-syntax) + (let-syntax . let-syntax) + (letrec-syntax . letrec-syntax) (define-c . define-c) (if . if) (lambda . lambda) diff --git a/scheme/eval.sld b/scheme/eval.sld index 78bbe3c8..837a5f7b 100644 --- a/scheme/eval.sld +++ b/scheme/eval.sld @@ -11,6 +11,7 @@ (import (scheme cyclone util) (scheme cyclone libraries) ;; for handling import sets + (scheme cyclone primitives) (scheme base) (scheme file) (scheme write) ;; Only used for debugging @@ -25,6 +26,17 @@ %import imported? %set-import-dirs! + *defined-macros* + get-macros + macro:macro? + macro:expand + macro:add! + macro:cleanup + macro:load-env! + macro:get-env + macro:get-defined-macros + expand + expand-lambda-body ) (inline primitive-implementation @@ -43,6 +55,7 @@ assignment-value assignment-variable variable? + macro:macro? ) (begin @@ -371,10 +384,10 @@ ;; - env => Environment used to expand macros ;; (define (analyze exp env) -;(newline) -;(display "/* ") -;(write (list 'analyze exp)) -;(display " */") +;;(newline) +;;(display "/* ") +;;(write (list 'analyze exp)) +;;(display " */") (cond ((self-evaluating? exp) (analyze-self-evaluating exp)) ((quoted? exp) (analyze-quoted exp)) @@ -388,6 +401,12 @@ ((and (syntax? exp) (not (null? (cdr exp)))) (analyze-syntax exp env)) + ((and (tagged-list? 'let-syntax exp) + (not (null? (cdr exp)))) + (analyze-let-syntax exp env)) + ((and (tagged-list? 'letrec-syntax exp) + (not (null? (cdr exp)))) + (analyze-letrec-syntax exp env)) ((and (if? exp) (not (null? (cdr exp)))) (analyze-if exp env)) @@ -434,26 +453,63 @@ (env:define-variable! var (vproc env) env) 'ok))) +(define (analyze-let-syntax exp a-env) + (let* ((rename-env (env:extend-environment '() '() '())) + (expanded (expand exp a-env rename-env)) + ;(expanded (expand exp (macro:get-env) rename-env)) + (cleaned (macro:cleanup expanded rename-env)) + ) + ;; TODO: probably just create a fresh env for renames + ;; TODO: expand, do we need to clean as well? + ;; TODO: run results back through analyze: (analyze (expand env? rename-env? +;;(display "/* ") +;;(write `(DEBUG ,cleaned)) +;;(display "*/ ") +;;(newline) + (analyze cleaned a-env))) + +(define (analyze-letrec-syntax exp a-env) + (let* ((rename-env (env:extend-environment '() '() '())) + ;; Build up a macro env + (vars (foldl (lambda (lis acc) (append acc (car lis))) '() a-env)) + (vals (foldl (lambda (lis acc) (append acc (cdr lis))) '() a-env)) + (zipped (apply map list vars (list vals))) + (defined-macros + (filter + (lambda (v) + (Cyc-macro? (Cyc-get-cvar (cadr v)))) + zipped)) + (macro-env + (env:extend-environment + (map car defined-macros) + (map (lambda (v) + (list 'macro (cadr v))) + defined-macros) + a-env)) ;(create-environment '() '()))) + ;; Proceed with macro env + (expanded (expand exp macro-env rename-env)) + (cleaned (macro:cleanup expanded rename-env)) + ) + (analyze cleaned a-env))) + (define (analyze-syntax exp a-env) (let ((var (cadr exp))) (cond - ((tagged-list? 'er-macro-transformer (caddr exp)) - (let ((sproc (make-macro (cadr (caddr exp))))) ;(analyze-syntax-lambda (cadr (caddr exp)) a-env))) + ((tagged-list? 'er-macro-transformer (caddr exp)) ;; TODO: need to handle renamed er symbol here?? + (let ((sproc (make-macro (cadr (caddr exp))))) (lambda (env) (env:define-variable! var sproc env) 'ok))) (else - ;; TODO: need to support syntax-rules, and other methods of - ;; building a macro. maybe call into something like - ;; analyze-syntax-lambda instead of erroring here - (error "macro syntax not supported yet"))))) - -;(define (analyze-syntax-lambda exp a-env) -; (let ((vars (lambda-parameters exp)) -; (bproc (analyze-sequence (lambda-body exp) a-env))) -; (write `(debug ,(lambda-body exp))) -; ;(lambda (env) -; (make-macro `(lambda ,vars ,@(lambda-body exp))))) + ;; Just expand the syntax rules + ;; Possibly want to check the macro system here + (let* ((rename-env (env:extend-environment '() '() '())) + (expanded (expand exp a-env rename-env)) + (cleaned (macro:cleanup expanded rename-env))) + (let ((sproc (make-macro (caddr cleaned)))) + (lambda (env) + (env:define-variable! var sproc env) + 'ok))))))) (define (analyze-import exp env) (lambda (env) @@ -663,4 +719,455 @@ " Cyc_check_str(data, 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 + +;; Macro expansion + +;TODO: modify this whole section to use macros:get-env instead of *defined-macros*. macro:get-env becomes the mac-env. any new scopes need to extend that env, and an env parameter needs to be added to (expand). any macros defined with define-syntax use that env as their mac-env (how to store that)? +; expand : exp -> exp + +(define (expand exp env rename-env) + (_expand exp env rename-env '())) + +(define (_expand exp env rename-env local-env) + (define (log e) + (display + (list 'expand e 'env + (env:frame-variables (env:first-frame env))) + (current-error-port)) + (newline (current-error-port))) + ;(log exp) +;;(display "/* ") +;;(write `(expand ,exp)) +;;(display "*/ ") +;;(newline) + (cond + ((const? exp) exp) + ((prim? exp) exp) + ((ref? exp) exp) + ((quote? exp) exp) + ((lambda? exp) `(lambda ,(lambda->formals exp) + ,@(_expand-body '() (lambda->exp exp) env rename-env local-env) + ;,@(map + ; ;; TODO: use extend env here? + ; (lambda (expr) (_expand expr env rename-env local-env)) + ; (lambda->exp exp)) + )) + ((define? exp) (if (define-lambda? exp) + (_expand (define->lambda exp) env rename-env local-env) + `(define ,(_expand (define->var exp) env rename-env local-env) + ,@(_expand (define->exp exp) env rename-env local-env)))) + ((set!? exp) `(set! ,(_expand (set!->var exp) env rename-env local-env) + ,(_expand (set!->exp exp) env rename-env local-env))) + ((if-syntax? exp) `(if ,(_expand (if->condition exp) env rename-env local-env) + ,(_expand (if->then exp) env rename-env local-env) + ,(if (if-else? exp) + (_expand (if->else exp) env rename-env local-env) + ;; Insert default value for missing else clause + ;; FUTURE: append the empty (unprinted) value + ;; instead of #f + #f))) + ((define-c? exp) exp) + ((define-syntax? exp) + ;(trace:info `(define-syntax ,exp)) + (let* ((name (cadr exp)) + (trans (caddr exp)) + (body (cadr trans))) + (cond + ((macro:syntax-rules? (env:lookup (car trans) env #f)) ;; Handles renamed 'syntax-rules' identifier + (_expand + `(define-syntax ,name ,(_expand trans env rename-env local-env)) + env rename-env local-env)) + (else + ;; TODO: for now, do not let a compiled macro be re-defined. + ;; this is a hack for performance compiling (scheme base) + (let ((macro (env:lookup name env #f))) + (cond + ((and (tagged-list? 'macro macro) + (or (Cyc-macro? (Cyc-get-cvar (cadr macro))) + (procedure? (cadr macro)))) + ;(trace:info `(DEBUG compiled macro ,name do not redefine)) + ) + (else + ;; Use this to keep track of macros for filtering unused defines + (set! *defined-macros* (cons (cons name body) *defined-macros*)) + ;; Keep track of macros added during compilation. + ;; TODO: why in both places? + (macro:add! name body) + (env:define-variable! name (list 'macro body) env))) + ;; Keep as a 'define' form so available at runtime + ;; TODO: may run into issues with expanding now, before some + ;; of the macros are defined. may need to make a special pass + ;; to do loading or expansion of macro bodies + `(define ,name ,(_expand body env rename-env local-env))))))) + ((let-syntax? exp) + (let* ((body (cons 'begin (cddr exp))) + (bindings (cadr exp)) + (bindings-as-macros + (map + (lambda (b) + (let* ((name (car b)) + (binding (cadr b)) + (binding-body (cadr binding))) +;(define tmp (env:lookup (car binding) env #f)) +;(display "/* ") +;(write `(DEBUG expand let-syntax +; ,(if (tagged-list? 'macro tmp) +; (Cyc-get-cvar (cadr tmp)) +; tmp) +; ,syntax-rules)) +;(display "*/ ") +;(newline) + (cons + name + (list + 'macro + ;; Broken for renames, replace w/below: (if (tagged-list? 'syntax-rules binding) + (if (macro:syntax-rules? (env:lookup (car binding) env #f)) + ;; TODO: is this ok? + (cadr (_expand binding env rename-env local-env)) + binding-body))))) + bindings)) + (new-local-macro-env (append bindings-as-macros local-env)) + ) +;(trace:error `(let-syntax ,new-local-macro-env)) + (_expand body env rename-env new-local-macro-env) ;; TODO: new-local-macro-env + )) + ((letrec-syntax? exp) + (let* ((body (cons 'begin (cddr exp))) + (body-env (env:extend-environment '() '() env)) + (bindings (cadr exp)) + ) + (for-each + (lambda (b) + (let* ((name (car b)) + (binding (cadr b)) + (binding-body (cadr binding)) + (macro-val + (list + 'macro + (if (macro:syntax-rules? (env:lookup (car binding) body-env #f)) + (cadr (_expand binding body-env rename-env local-env)) + binding-body)))) + (env:define-variable! name macro-val) body-env)) + bindings) + (_expand body body-env rename-env local-env) + )) + ((app? exp) + (cond + ((symbol? (car exp)) + (let ((val (let ((local (assoc (car exp) local-env))) + (if local + (cdr local) + (let ((v (env:lookup (car exp) env #f))) + v ;; TODO: below was for looking up a renamed macro. may want to consider using it + ;; in the symbol condition below... + #;(if v + v + (env:lookup (car exp) rename-env #f))))))) +;;(display "/* ") +;;(write `(app DEBUG ,(car exp) ,val ,env ,local-env ,rename-env ,(env:lookup (car exp) env #f))) +;;(display "*/ ") +;;(newline) + (cond + ((tagged-list? 'macro val) + (_expand ; Could expand into another macro + (macro:expand exp val env rename-env) + env + rename-env + local-env)) + ((Cyc-macro? val) + (_expand ; Could expand into another macro + (macro:expand exp (list 'macro val) env rename-env) + env + rename-env + local-env)) +;; TODO: if we are doing this, only want to do so if the original variable is a macro. +;; this is starting to get overly complicated though. +;; if nothing else should encapsulate the above lookup into a function and call that +;; in both places (above and here) to simplify things +;; +;; ((and (symbol? val) +;; (not (eq? val (car exp)))) +;; ;; Original macro symbol was renamed. So try again with the orignal symbol +;;(display "/* ") +;;(write `(app DEBUG-syms ,(car exp) ,val ,local-env ,(cdr exp))) +;;(display "*/ ") +;;(newline) +;; (_expand +;; (cons val (cdr exp)) +;; env rename-env local-env)) + (else + (map + (lambda (expr) (_expand expr env rename-env local-env)) + exp))))) + (else + ;; TODO: note that map does not guarantee that expressions are + ;; evaluated in order. For example, the list might be processed + ;; in reverse order. Might be better to use a fold here and + ;; elsewhere in (expand). + (map + (lambda (expr) (_expand expr env rename-env local-env)) + exp)))) + (else + (error "unknown exp: " exp)))) + +(define (macro:syntax-rules? exp) + (eq? + syntax-rules + (if (tagged-list? 'macro exp) + (Cyc-get-cvar (cadr exp)) + exp))) + +;; Nicer interface to expand-body +(define (expand-lambda-body exp env rename-env) + (expand-body '() exp env rename-env)) + +;; Helper to expand a lambda body, so we can splice in any begin's +(define (expand-body result exp env rename-env) + (_expand-body result exp env rename-env '())) + +(define (_expand-body result exp env rename-env local-env) + (define (log e) + (display (list 'expand-body e 'env + (env:frame-variables (env:first-frame env))) + (current-error-port)) + (newline (current-error-port))) + + (if (null? exp) + (reverse result) + (let ((this-exp (car exp))) +;(display (list 'expand-body this-exp) (current-error-port)) +;(newline (current-error-port)) + (cond + ((or (const? this-exp) + (prim? this-exp) + (ref? this-exp) + (quote? this-exp) + (define-c? this-exp)) +;(log this-exp) + (_expand-body (cons this-exp result) (cdr exp) env rename-env local-env)) + ((define? this-exp) +;(log this-exp) + (_expand-body + (cons + (_expand this-exp env rename-env local-env) + result) + (cdr exp) + env + rename-env + local-env)) + ((or (define-syntax? this-exp) + (letrec-syntax? this-exp) + (let-syntax? this-exp) + (lambda? this-exp) + (set!? this-exp) + (if? this-exp)) +;(log (car this-exp)) + (_expand-body + (cons + (_expand this-exp env rename-env local-env) + result) + (cdr exp) + env + rename-env + local-env)) + ;; Splice in begin contents and keep expanding body + ((begin? this-exp) + (let* ((expr this-exp) + (begin-exprs (begin->exps expr))) +;(log (car this-exp)) + (_expand-body + result + (append begin-exprs (cdr exp)) + env + rename-env + local-env))) + ((app? this-exp) + (cond + ((symbol? (caar exp)) +;(log (car this-exp)) + (let ((val (let ((local (assoc (caar exp) local-env))) + (if local + (cdr local) + (env:lookup (caar exp) env #f))))) +;(log `(DONE WITH env:lookup ,(caar exp) ,val ,(tagged-list? 'macro val))) + (if (tagged-list? 'macro val) + ;; Expand macro here so we can catch begins in the expanded code, + ;; including nested begins + (let ((expanded (macro:expand this-exp val env rename-env))) +;(log `(DONE WITH macro:expand)) + (_expand-body + result + (cons + expanded ;(macro:expand this-exp val env) + (cdr exp)) + env + rename-env + local-env)) + ;; No macro, use main expand function to process + (_expand-body + (cons + (map + (lambda (expr) (_expand expr env rename-env local-env)) + this-exp) + result) + (cdr exp) + env + rename-env + local-env)))) + (else +;(log 'app) + (_expand-body + (cons + (map + (lambda (expr) (_expand expr env rename-env local-env)) + this-exp) + result) + (cdr exp) + env + rename-env + local-env)))) + (else + (error "unknown exp: " this-exp)))))) + +;; Container for built-in macros +(define (get-macros) *defined-macros*) +(define *defined-macros* (list)) + +(define (begin->exps exp) + (cdr exp)) + )) diff --git a/scheme/repl.sld b/scheme/repl.sld new file mode 100644 index 00000000..38f56fd0 --- /dev/null +++ b/scheme/repl.sld @@ -0,0 +1,17 @@ +;;;; Cyclone Scheme +;;;; https://github.com/justinethier/cyclone +;;;; +;;;; Copyright (c) 2014-2016, Justin Ethier +;;;; All rights reserved. +;;;; +;;;; This module contains the repl library from r7rs. +;;;; +(define-library (scheme repl) + (export + interaction-environment + ) + (import (scheme eval)) + (begin + (define (interaction-environment) + (setup-environment)) + )) diff --git a/tests/let-syntax-298.scm b/tests/let-syntax-298.scm new file mode 100644 index 00000000..652f30c4 --- /dev/null +++ b/tests/let-syntax-298.scm @@ -0,0 +1,18 @@ +;; From: +;; https://github.com/ashinn/chibi-scheme/issues/298 +(import (scheme base) (scheme write)) + +(define-syntax bar + (syntax-rules () + ((_) + (let-syntax ((foo (syntax-rules () ((_) 'ok)))) + (foo))))) + +(define-syntax foo (syntax-rules () ((_) 'foo))) + +(write +(bar) +) +(write +(foo) +) diff --git a/tests/let-syntax.scm b/tests/let-syntax.scm index 69af2d17..a13ac537 100644 --- a/tests/let-syntax.scm +++ b/tests/let-syntax.scm @@ -1,4 +1,143 @@ -(import (scheme base) (scheme write)) +(import (scheme base) (scheme write) (scheme cyclone pretty-print)) + +;; Just testing, may want to remove this one once the recursive macro expansion works +; (define-syntax my-or2 (syntax-rules () +; ((my-or2) #f) +; ((my-or2 e) e) +; ((my-or2 e1 e2 ...) +; (let ((temp e1)) (if temp temp (my-or2 e2 ...)))))) +;(write (my-or2 #t)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; (define-syntax my-or (syntax-rules () +; ((my-or) #f) +; ((my-or e) e) +; ((my-or e1 e2 ...) +; (let ((temp e1)) (if temp temp (my-or e2 ...)))))) +; (write +; (let ((x #f) +; (y 7) +; (temp 8) +; (my-let odd?) +; (my-if even?)) +; (my-or x (my-let temp) (my-if y) y))) ;; ==> 7 +; +; (define-syntax foo (syntax-rules () +; ((_ b) +; (bar a b)))) +; (define-syntax bar (syntax-rules () ((_ c d) +; (cons c (let ((c 3)) +; (list d c 'c)))))) +; (write +; (let ((a 2)) +; (foo a))) + +;; Chibi also fails with the same error when this is a let-synatx macro, +;; so it may be that Cyclone works just fine here! Obviously it needs +;; to be able to handle this macro in letrec-syntax form, though +#;(let-syntax + ((my-or (syntax-rules () + ((my-or) #f) + ((my-or e) e) + ((my-or e1 e2 ...) + (let ((temp e1)) (if temp temp (my-or e2 ...))))))) + (let ((x #f) + (y 7) + (temp 8) + (my-let odd?) + (my-if even?)) + (my-or x (my-let temp) (my-if y) y))) ;; ==> 7 + +;; TODO: below should work with "let" and "if" instead of "my-let" and "my-if" +;; TODO: below does not work in eval - WTF? +(write +(letrec-syntax + ((my-or (syntax-rules () + ((my-or) #f) + ((my-or e) e) + ((my-or e1 e2 ...) + (let ((temp e1)) (if temp temp (my-or e2 ...))))))) + (let ((x #f) + (y 7) + (temp 8) + (my-let odd?) + (my-if even?)) + (my-or x (my-let temp) (my-if y) y))) ;; ==> 7 +) + + +;; From Chibi - isn't this a bug though? +;(write +;(let () +; (letrec-syntax () +; (define internal-def 'ok)) +; internal-def) +;) + +;; From Husk: +;; +; Examples from the source to R5RS pitfall 3.3 +;; (assert/equal +;; (let ((a 1)) +;; (letrec-syntax +;; ((foo (syntax-rules () +;; ((_ b) +;; (bar a b)))) +;; (bar (syntax-rules () +;; ((_ c d) +;; (cons c (let ((c 3)) +;; (list d c 'c))))))) +;; (let ((a 2)) +;; (foo a)))) +;; '(1 2 3 a)) +;; +;; ; Examples from/based on pitfall 8.3 (assert/equal 1 +;; (let ((x 1)) +;; (let-syntax ((foo (syntax-rules () ((_) 2)))) +;; (define x (foo)) +;; 3) +;; x)) +;; (assert/equal 1 +;; (let ((x 1)) +;; (letrec-syntax ((foo (syntax-rules () ((_) 2)))) (define x (foo)) +;; 3) +;; x)) +;; +;; ; Issue #151 - Preserve hygiene across syntax-rules and ER macros +;; (assert/equal +;; (let ((unquote 'foo)) `(,'bar)) +;; '(,'bar)) + + +#;(let ((a 1)) + (let-syntax + ;;(letrec-syntax + ((foo (syntax-rules () + ((_ b) + (bar a b)))) + (bar (syntax-rules () ((_ c d) + (cons c (let ((c 3)) + (list d c 'c))))))) + (let ((a 2)) + (foo a)))) + + +(define-syntax my-let + (syntax-rules + () + ((my-let ((name val) ...) body1 body2 ...) + ((lambda (name ...) body1 body2 ...) val ...)) + ((my-let tag ((name val) ...) body1 body2 ...) + ((letrec ((tag (lambda (name ...) body1 body2 ...))) + tag) + val ...)))) +(write +(my-let ((x 'outer)) + (let-syntax ((m (syntax-rules () ((m) x)))) + (my-let ((x 'inner)) + (m)))) ;; Should be outer + ) + ;; (let-syntax ((given-that (syntax-rules () ;; ((given-that test stmt1 stmt2 ...) @@ -9,17 +148,19 @@ ;; (given-that if (set! if 'now)) ;; if)) ;; => now -;;(let ((x 'outer)) -;; (let-syntax ((m (syntax-rules () ((m) x)))) -;; (let ((x 'inner)) -;; (m)))) ;; Should be outer - -(write +(write (let ((x 'outer)) - (define-syntax m ;; Testing this out, but let-syntax needs to work, too - (syntax-rules () ((m) x))) + (let-syntax ((m (syntax-rules () ((m) x)))) (let ((x 'inner)) - (m))) ;; Should be outer + (m)))) ;; Should be outer ) -(write (m)) ;; Should be an error, of course +;(write +;(let ((x 'outer)) +; (define-syntax m ;; Testing this out, but let-syntax needs to work, too +; (syntax-rules () ((m) x))) +; (let ((x 'inner)) +; (m))) ;; Should be outer +; ) +; +;(write (m)) ;; Should be an error, of course diff --git a/tests/when.scm b/tests/when.scm new file mode 100644 index 00000000..8d044155 --- /dev/null +++ b/tests/when.scm @@ -0,0 +1,103 @@ +(import (scheme base) (scheme write)) +;(define-syntax my-when +; (syntax-rules () +; ((my-when test result1 result2 ...) +; (if test +; (begin result1 result2 ...))))) + +(define-syntax my-when2 + (syntax-rules () + ((my-when test result1 result2 ...) + (list result2 ...)))) + +(write + (my-when2 #t 1)) +; +; (define my-when2* +; (lambda (expr$28 rename$29 compare$30) +; (car ((lambda (tmp$42) +; (if tmp$42 +; tmp$42 +; (cons (error "no expansion for" expr$28) #f))) +; ((lambda (v.1$36) +; (if (pair? v.1$36) +; ((lambda (v.2$37) +; ((lambda (test) +; ((lambda (v.3$38) +; (if (pair? v.3$38) +; ((lambda (v.4$39) +; ((lambda (result1) +; ((lambda (v.5$40) +; (if (list? v.5$40) +; ((lambda (result2) +; (cons (cons-source +; (rename$29 'list) +; (cons-source test '() '(test)) +; '(list test)) +; #f)) +; v.5$40) +; #f)) +; (cdr v.3$38))) +; v.4$39)) +; (car v.3$38)) +; #f)) +; (cdr v.1$36))) +; v.2$37)) +; (car v.1$36)) +; #f)) +; (cdr expr$28)))))) + + +;; TODO: seems broken +;(define-syntax my-when4 +; (syntax-rules () +; ((my-when test result1 result2 ...) +; (let-syntax +; ((second +; (syntax-rules () +; ((second a b c) +; b)))) +; (second 33 44 55))))) +;(write +; (my-when4 't 1 2 3)) + +;; The symbol?? macro from oleg: +;; http://okmij.org/ftp/Scheme/macros.html#macro-symbol-p + (define-syntax symbol?? + (syntax-rules () + ((symbol?? (x . y) kt kf) kf) ; It's a pair, not a symbol + ((symbol?? #(x ...) kt kf) kf) ; It's a vector, not a symbol + ((symbol?? maybe-symbol kt kf) + (let-syntax + ((test + (syntax-rules () + ((test maybe-symbol t f) t) + ((test x t f) f)))) + (test abracadabra kt kf))))) +(write (symbol?? a #t #f)) +(write (symbol?? "a" #t #f)) + +(write + (let-syntax + ((second + (syntax-rules () + ((second a b c) + b)))) + (second 33 44 55))) + +(write + (my-when2 + 't + 1 + (let-syntax + ((my-when3 + (syntax-rules () + ((my-when3 test result1 result2 ...) + (list result2 ...))))) + (my-when3 33 44 55)) + 2 + 3)) +;(write +; (my-when2 '(my-when2 't 1 2 3) (lambda (a) a) (lambda X #f))) +;(write +; (my-when2 '(my-when2 "testing" 1) (lambda (a) a) (lambda X #f))) diff --git a/tmp-macro-test.scm b/tmp-macro-test.scm new file mode 100644 index 00000000..5c18a472 --- /dev/null +++ b/tmp-macro-test.scm @@ -0,0 +1,26 @@ +;; This is a temporary test file +(import (scheme base) (scheme write) (scheme eval) (scheme cyclone util)) + +(define env (env:extend-environment '() '() env:the-empty-environment)) +(define env2 (env:extend-environment '(a b c) '(1 2 3) env)) + +(define a-env (create-environment '() '())) + +(let* ( +(vars (foldl (lambda (lis acc) (append acc (car lis))) '() a-env)) +(vals (foldl (lambda (lis acc) (append acc (cdr lis))) '() a-env)) +(zipped (apply map list vars (list vals))) +(defined-macros + (filter + (lambda (v) + (Cyc-macro? (Cyc-get-cvar (cadr v)))) + zipped)) +(macro-env + (env:extend-environment + (map car defined-macros) + (map (lambda (v) + (list 'macro (cadr v))) + defined-macros) + '())) ;; base-env +) + (write (list vars vals zipped defined-macros macro-env)))