Fcalva/cyclone
1
0
Fork 0
mirror of https://github.com/justinethier/cyclone.git synced 2025-05-25 04:55:04 +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 features
and and
or or
quasiquote
) )
(begin (begin
;; Features implemented by this Scheme ;; Features implemented by this Scheme
@ -105,6 +106,38 @@
(list (rename 'if) (rename 'tmp) (list (rename 'if) (rename 'tmp)
(rename 'tmp) (rename 'tmp)
(cons (rename 'or) (cddr expr))))))))) (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. ;; 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) (define call-with-current-continuation call/cc)

31
scheme/cyclone/transforms.sld
View file

@ -255,37 +255,6 @@
`(,(rename 'begin) ,@(cdar ls)))) `(,(rename 'begin) ,@(cdar ls))))
((check (caar ls)) `(,(rename 'begin) ,@(cdar ls))) ((check (caar ls)) `(,(rename 'begin) ,@(cdar ls)))
(else (expand (cdr 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) (define (quoted? exp)
(tagged-list? 'quote exp)) (tagged-list? 'quote exp))
(define (quasiquoted? exp)
(tagged-list? 'quasiquote exp))
(define (assignment? exp) (define (assignment? exp)
(tagged-list? 'set! exp)) (tagged-list? 'set! exp))
(define (assignment-variable exp) (cadr exp)) (define (assignment-variable exp) (cadr exp))
@ -403,7 +400,6 @@
(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))
((quasiquoted? exp) (analyze-quasiquoted exp))
((variable? exp) (analyze-variable exp)) ((variable? exp) (analyze-variable exp))
((assignment? exp) (analyze-assignment exp env)) ((assignment? exp) (analyze-assignment exp env))
((definition? exp) (analyze-definition exp env)) ((definition? exp) (analyze-definition exp env))
@ -442,9 +438,6 @@
(let ((qval (cadr exp))) (let ((qval (cadr exp)))
(lambda (env) qval))) (lambda (env) qval)))
(define (analyze-quasiquoted exp)
(error "quasiquote not supported yet by eval"))
(define (analyze-variable exp) (define (analyze-variable exp)
(lambda (env) (lookup-variable-value exp env))) (lambda (env) (lookup-variable-value exp env)))