mirror of
https://github.com/justinethier/cyclone.git
synced 2025-07-12 23:37:38 +02:00
Merge branch 'syntax-dev2'
This commit is contained in:
Justin Ethier
commit
82bd14d38f
15 changed files with 891 additions and 401 deletions
10
CHANGELOG.md
10
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
|
||||
|
|
|
|||
1
Makefile
1
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -9,6 +9,7 @@
|
|||
(define-library (scheme cyclone cgen)
|
||||
(import (scheme base)
|
||||
(scheme char)
|
||||
(scheme eval)
|
||||
(scheme inexact)
|
||||
(scheme write)
|
||||
(scheme cyclone primitives)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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?
|
||||
|
|
@ -121,6 +126,14 @@
|
|||
(= (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)
|
||||
|
|
|
|||
541
scheme/eval.sld
541
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))
|
||||
|
||||
))
|
||||
|
|
|
|||
17
scheme/repl.sld
Normal file
17
scheme/repl.sld
Normal file
|
|
@ -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))
|
||||
))
|
||||
18
tests/let-syntax-298.scm
Normal file
18
tests/let-syntax-298.scm
Normal file
|
|
@ -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)
|
||||
)
|
||||
|
|
@ -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
|
||||
(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
|
||||
|
|
|
|||
103
tests/when.scm
Normal file
103
tests/when.scm
Normal file
|
|
@ -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)))
|
||||
26
tmp-macro-test.scm
Normal file
26
tmp-macro-test.scm
Normal file
|
|
@ -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)))
|
||||
Loading…
Add table
Reference in a new issue