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

Relocated case to scheme/base

Browse source
This commit is contained in:
Justin Ethier 2015-08-20 21:31:36 -04:00
parent 6b6585b7e7
commit a228027ac4
2 changed files with 29 additions and 27 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

29
scheme/base.sld
View file

@ -87,6 +87,7 @@
let let
let* let*
begin begin
case
cond cond
when when
quasiquote quasiquote
@ -193,6 +194,34 @@
(cons (rename 'begin) (cdr cl)) (cons (rename 'begin) (cdr cl))
(cons (rename 'cond) (cddr expr)))))) (cons (rename 'cond) (cddr expr))))))
(cadr expr)))))) (cadr expr))))))
(define-syntax case
(er-macro-transformer
(lambda (expr rename compare)
(define (body exprs)
(cond
((null? exprs)
(rename 'tmp))
((compare (rename '=>) (car exprs))
`(,(cadr exprs) ,(rename 'tmp)))
(else
`(,(rename 'begin) ,@exprs))))
(define (clause ls)
(cond
((null? ls) #f)
((compare (rename 'else) (caar ls))
(body (cdar ls)))
((and (pair? (car (car ls))) (null? (cdr (car (car ls)))))
`(,(rename 'if) (,(rename 'eqv?) ,(rename 'tmp)
(,(rename 'quote) ,(car (caar ls))))
,(body (cdar ls))
,(clause (cdr ls))))
(else
`(,(rename 'if) (,(rename 'memv) ,(rename 'tmp)
(,(rename 'quote) ,(caar ls)))
,(body (cdar ls))
,(clause (cdr ls))))))
`(let ((,(rename 'tmp) ,(cadr expr)))
,(clause (cddr expr))))))
(define-syntax when (define-syntax when
(er-macro-transformer (er-macro-transformer
(lambda (exp rename compare) (lambda (exp rename compare)

27
scheme/cyclone/transforms.sld
View file

@ -139,33 +139,6 @@
(define *defined-macros* (define *defined-macros*
(list (list
(cons 'letrec (lambda (exp rename compare) (letrec=>lets+sets exp))) (cons 'letrec (lambda (exp rename compare) (letrec=>lets+sets exp)))
(cons 'case
(lambda (expr rename compare)
(define (body exprs)
(cond
((null? exprs)
(rename 'tmp))
((compare (rename '=>) (car exprs))
`(,(cadr exprs) ,(rename 'tmp)))
(else
`(,(rename 'begin) ,@exprs))))
(define (clause ls)
(cond
((null? ls) #f)
((compare (rename 'else) (caar ls))
(body (cdar ls)))
((and (pair? (car (car ls))) (null? (cdr (car (car ls)))))
`(,(rename 'if) (,(rename 'eqv?) ,(rename 'tmp)
(,(rename 'quote) ,(car (caar ls))))
,(body (cdar ls))
,(clause (cdr ls))))
(else
`(,(rename 'if) (,(rename 'memv) ,(rename 'tmp)
(,(rename 'quote) ,(caar ls)))
,(body (cdar ls))
,(clause (cdr ls))))))
`(let ((,(rename 'tmp) ,(cadr expr)))
,(clause (cddr expr)))))
(cons 'cond-expand (cons 'cond-expand
;; Based on the cond-expand macro from Chibi scheme ;; Based on the cond-expand macro from Chibi scheme
(lambda (expr rename compare) (lambda (expr rename compare)