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

Move quasiquote to scheme/base

Browse source
This commit is contained in:
Justin Ethier 2015-08-19 22:03:12 -04:00
parent a85e757070
commit 7a6c6a6727
3 changed files with 33 additions and 38 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

33
scheme/base.sld
View file

@ -82,6 +82,7 @@
features
and
or
quasiquote
)
(begin
;; Features implemented by this Scheme
@ -105,6 +106,38 @@
(list (rename 'if) (rename 'tmp)
(rename 'tmp)
(cons (rename 'or) (cddr expr)))))))))
(define-syntax quasiquote
(er-macro-transformer
;; Based on the quasiquote macro from Chibi scheme
(lambda (expr rename compare)
(define (qq x d)
(cond
((pair? x)
(cond
((compare (rename 'unquote) (car x))
(if (<= d 0)
(cadr x)
(list (rename 'list) (list (rename 'quote) 'unquote)
(qq (cadr x) (- d 1)))))
((compare (rename 'unquote-splicing) (car x))
(if (<= d 0)
(list (rename 'cons) (qq (car x) d) (qq (cdr x) d))
(list (rename 'list) (list (rename 'quote) 'unquote-splicing)
(qq (cadr x) (- d 1)))))
((compare (rename 'quasiquote) (car x))
(list (rename 'list) (list (rename 'quote) 'quasiquote)
(qq (cadr x) (+ d 1))))
((and (<= d 0) (pair? (car x))
(compare (rename 'unquote-splicing) (caar x)))
(if (null? (cdr x))
(cadr (car x))
(list (rename 'append) (cadr (car x)) (qq (cdr x) d))))
(else
(list (rename 'cons) (qq (car x) d) (qq (cdr x) d)))))
((vector? x) (list (rename 'list->vector) (qq (vector->list x) d)))
((if (symbol? x) #t (null? x)) (list (rename 'quote) x))
(else x)))
(qq (cadr expr) 0))))
;; TODO: The whitespace characters are space, tab, line feed, form feed (not in parser yet), and carriage return.
(define call-with-current-continuation call/cc)

31
scheme/cyclone/transforms.sld
View file

@ -255,37 +255,6 @@
`(,(rename 'begin) ,@(cdar ls))))
((check (caar ls)) `(,(rename 'begin) ,@(cdar ls)))
(else (expand (cdr ls)))))))
(cons 'quasiquote
;; Based on the quasiquote macro from Chibi scheme
(lambda (expr rename compare)
(define (qq x d)
(cond
((pair? x)
(cond
((compare (rename 'unquote) (car x))
(if (<= d 0)
(cadr x)
(list (rename 'list) (list (rename 'quote) 'unquote)
(qq (cadr x) (- d 1)))))
((compare (rename 'unquote-splicing) (car x))
(if (<= d 0)
(list (rename 'cons) (qq (car x) d) (qq (cdr x) d))
(list (rename 'list) (list (rename 'quote) 'unquote-splicing)
(qq (cadr x) (- d 1)))))
((compare (rename 'quasiquote) (car x))
(list (rename 'list) (list (rename 'quote) 'quasiquote)
(qq (cadr x) (+ d 1))))
((and (<= d 0) (pair? (car x))
(compare (rename 'unquote-splicing) (caar x)))
(if (null? (cdr x))
(cadr (car x))
(list (rename 'append) (cadr (car x)) (qq (cdr x) d))))
(else
(list (rename 'cons) (qq (car x) d) (qq (cdr x) d)))))
((vector? x) (list (rename 'list->vector) (qq (vector->list x) d)))
((if (symbol? x) #t (null? x)) (list (rename 'quote) x))
(else x)))
(qq (cadr expr) 0)))
))

7
scheme/eval.sld
View file

@ -62,9 +62,6 @@
(define (quoted? exp)
(tagged-list? 'quote exp))
(define (quasiquoted? exp)
(tagged-list? 'quasiquote exp))
(define (assignment? exp)
(tagged-list? 'set! exp))
(define (assignment-variable exp) (cadr exp))
@ -403,7 +400,6 @@
(cond ((self-evaluating? exp)
(analyze-self-evaluating exp))
((quoted? exp) (analyze-quoted exp))
((quasiquoted? exp) (analyze-quasiquoted exp))
((variable? exp) (analyze-variable exp))
((assignment? exp) (analyze-assignment exp env))
((definition? exp) (analyze-definition exp env))
@ -442,9 +438,6 @@
(let ((qval (cadr exp)))
(lambda (env) qval)))
(define (analyze-quasiquoted exp)
(error "quasiquote not supported yet by eval"))
(define (analyze-variable exp)
(lambda (env) (lookup-variable-value exp env)))