move core syntaxes
This commit is contained in:
Yuichi Nishiwaki
parent
685d21a1e2
commit
c3ef97992d
|
|
@ -214,4 +214,257 @@
|
|||
(export write
|
||||
write-simple
|
||||
write-shared
|
||||
display))
|
||||
display)
|
||||
|
||||
(define-syntax syntax-error
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(apply error (cdr expr)))))
|
||||
|
||||
(define-syntax define-auxiliary-syntax
|
||||
(er-macro-transformer
|
||||
(lambda (expr r c)
|
||||
(list (r 'define-syntax) (cadr expr)
|
||||
(list (r 'lambda) '_
|
||||
(list (r 'error) "invalid use of auxiliary syntax"))))))
|
||||
|
||||
(define-auxiliary-syntax else)
|
||||
(define-auxiliary-syntax =>)
|
||||
(define-auxiliary-syntax _)
|
||||
(define-auxiliary-syntax ...)
|
||||
(define-auxiliary-syntax unquote)
|
||||
(define-auxiliary-syntax unquote-splicing)
|
||||
|
||||
(define-syntax let
|
||||
(er-macro-transformer
|
||||
(lambda (expr r compare)
|
||||
(if (symbol? (cadr expr))
|
||||
(begin
|
||||
(define name (car (cdr expr)))
|
||||
(define bindings (car (cdr (cdr expr))))
|
||||
(define body (cdr (cdr (cdr expr))))
|
||||
(list (r 'let) '()
|
||||
(list (r 'define) name
|
||||
(cons (r 'lambda) (cons (map car bindings) body)))
|
||||
(cons name (map cadr bindings))))
|
||||
(begin
|
||||
(set! bindings (cadr expr))
|
||||
(set! body (cddr expr))
|
||||
(cons (cons (r 'lambda) (cons (map car bindings) body))
|
||||
(map cadr bindings)))))))
|
||||
|
||||
(define-syntax cond
|
||||
(er-macro-transformer
|
||||
(lambda (expr r compare)
|
||||
(let ((clauses (cdr expr)))
|
||||
(if (null? clauses)
|
||||
#f
|
||||
(begin
|
||||
(define clause (car clauses))
|
||||
(if (compare (r 'else) (car clause))
|
||||
(cons (r 'begin) (cdr clause))
|
||||
(if (if (>= (length clause) 2)
|
||||
(compare (r '=>) (list-ref clause 1))
|
||||
#f)
|
||||
(list (r 'let) (list (list (r 'x) (car clause)))
|
||||
(list (r 'if) (r 'x)
|
||||
(list (list-ref clause 2) (r 'x))
|
||||
(cons (r 'cond) (cdr clauses))))
|
||||
(list (r 'if) (car clause)
|
||||
(cons (r 'begin) (cdr clause))
|
||||
(cons (r 'cond) (cdr clauses)))))))))))
|
||||
|
||||
(define-syntax and
|
||||
(er-macro-transformer
|
||||
(lambda (expr r compare)
|
||||
(let ((exprs (cdr expr)))
|
||||
(cond
|
||||
((null? exprs)
|
||||
#t)
|
||||
((= (length exprs) 1)
|
||||
(car exprs))
|
||||
(else
|
||||
(list (r 'let) (list (list (r 'it) (car exprs)))
|
||||
(list (r 'if) (r 'it)
|
||||
(cons (r 'and) (cdr exprs))
|
||||
(r 'it)))))))))
|
||||
|
||||
(define-syntax or
|
||||
(er-macro-transformer
|
||||
(lambda (expr r compare)
|
||||
(let ((exprs (cdr expr)))
|
||||
(cond
|
||||
((null? exprs)
|
||||
#t)
|
||||
((= (length exprs) 1)
|
||||
(car exprs))
|
||||
(else
|
||||
(list (r 'let) (list (list (r 'it) (car exprs)))
|
||||
(list (r 'if) (r 'it)
|
||||
(r 'it)
|
||||
(cons (r 'or) (cdr exprs))))))))))
|
||||
|
||||
(define-syntax quasiquote
|
||||
(ir-macro-transformer
|
||||
(lambda (form inject compare)
|
||||
|
||||
(define (quasiquote? form)
|
||||
(and (pair? form) (compare (car form) 'quasiquote)))
|
||||
|
||||
(define (unquote? form)
|
||||
(and (pair? form) (compare (car form) 'unquote)))
|
||||
|
||||
(define (unquote-splicing? form)
|
||||
(and (pair? form) (pair? (car form))
|
||||
(compare (car (car form)) 'unquote-splicing)))
|
||||
|
||||
(define (qq depth expr)
|
||||
(cond
|
||||
;; unquote
|
||||
((unquote? expr)
|
||||
(if (= depth 1)
|
||||
(car (cdr expr))
|
||||
(list 'list
|
||||
(list 'quote (inject 'unquote))
|
||||
(qq (- depth 1) (car (cdr expr))))))
|
||||
;; unquote-splicing
|
||||
((unquote-splicing? expr)
|
||||
(if (= depth 1)
|
||||
(list 'append
|
||||
(car (cdr (car expr)))
|
||||
(qq depth (cdr expr)))
|
||||
(list 'cons
|
||||
(list 'list
|
||||
(list 'quote (inject 'unquote-splicing))
|
||||
(qq (- depth 1) (car (cdr (car expr)))))
|
||||
(qq depth (cdr expr)))))
|
||||
;; quasiquote
|
||||
((quasiquote? expr)
|
||||
(list 'list
|
||||
(list 'quote (inject 'quasiquote))
|
||||
(qq (+ depth 1) (car (cdr expr)))))
|
||||
;; list
|
||||
((pair? expr)
|
||||
(list 'cons
|
||||
(qq depth (car expr))
|
||||
(qq depth (cdr expr))))
|
||||
;; vector
|
||||
((vector? expr)
|
||||
(list 'list->vector (qq depth (vector->list expr))))
|
||||
;; simple datum
|
||||
(else
|
||||
(list 'quote expr))))
|
||||
|
||||
(let ((x (cadr form)))
|
||||
(qq 1 x)))))
|
||||
|
||||
(define-syntax let*
|
||||
(er-macro-transformer
|
||||
(lambda (form r compare)
|
||||
(let ((bindings (cadr form))
|
||||
(body (cddr form)))
|
||||
(if (null? bindings)
|
||||
`(,(r 'let) () ,@body)
|
||||
`(,(r 'let) ((,(caar bindings)
|
||||
,@(cdar bindings)))
|
||||
(,(r 'let*) (,@(cdr bindings))
|
||||
,@body)))))))
|
||||
|
||||
(define-syntax letrec*
|
||||
(er-macro-transformer
|
||||
(lambda (form r compare)
|
||||
(let ((bindings (cadr form))
|
||||
(body (cddr form)))
|
||||
(let ((vars (map (lambda (v) `(,v #f)) (map car bindings)))
|
||||
(initials (map (lambda (v) `(,(r 'set!) ,@v)) bindings)))
|
||||
`(,(r 'let) (,@vars)
|
||||
,@initials
|
||||
,@body))))))
|
||||
|
||||
(define-syntax letrec
|
||||
(er-macro-transformer
|
||||
(lambda (form rename compare)
|
||||
`(,(rename 'letrec*) ,@(cdr form)))))
|
||||
|
||||
(define-syntax do
|
||||
(er-macro-transformer
|
||||
(lambda (form r compare)
|
||||
(let ((bindings (car (cdr form)))
|
||||
(finish (car (cdr (cdr form))))
|
||||
(body (cdr (cdr (cdr form)))))
|
||||
`(,(r 'let) ,(r 'loop) ,(map (lambda (x)
|
||||
(list (car x) (cadr x)))
|
||||
bindings)
|
||||
(,(r 'if) ,(car finish)
|
||||
(,(r 'begin) ,@(cdr finish))
|
||||
(,(r 'begin) ,@body
|
||||
(,(r 'loop) ,@(map (lambda (x)
|
||||
(if (null? (cddr x))
|
||||
(car x)
|
||||
(car (cddr x))))
|
||||
bindings)))))))))
|
||||
|
||||
(define-syntax when
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let ((test (cadr expr))
|
||||
(body (cddr expr)))
|
||||
`(,(rename 'if) ,test
|
||||
(,(rename 'begin) ,@body)
|
||||
#f)))))
|
||||
|
||||
(define-syntax unless
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let ((test (cadr expr))
|
||||
(body (cddr expr)))
|
||||
`(,(rename 'if) ,test
|
||||
#f
|
||||
(,(rename 'begin) ,@body))))))
|
||||
|
||||
(define-syntax case
|
||||
(er-macro-transformer
|
||||
(lambda (expr r compare)
|
||||
(let ((key (cadr expr))
|
||||
(clauses (cddr expr)))
|
||||
`(,(r 'let) ((,(r 'key) ,key))
|
||||
,(let loop ((clauses clauses))
|
||||
(if (null? clauses)
|
||||
#f
|
||||
(begin
|
||||
(define clause (car clauses))
|
||||
`(,(r 'if) ,(if (compare (r 'else) (car clause))
|
||||
'#t
|
||||
`(,(r 'or)
|
||||
,@(map (lambda (x)
|
||||
`(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x)))
|
||||
(car clause))))
|
||||
,(if (compare (r '=>) (list-ref clause 1))
|
||||
`(,(list-ref clause 2) ,(r 'key))
|
||||
`(,(r 'begin) ,@(cdr clause)))
|
||||
,(loop (cdr clauses)))))))))))
|
||||
|
||||
(define-syntax letrec-syntax
|
||||
(er-macro-transformer
|
||||
(lambda (form r c)
|
||||
(let ((formal (car (cdr form)))
|
||||
(body (cdr (cdr form))))
|
||||
`(let ()
|
||||
,@(map (lambda (x)
|
||||
`(,(r 'define-syntax) ,(car x) ,(cadr x)))
|
||||
formal)
|
||||
,@body)))))
|
||||
|
||||
(define-syntax let-syntax
|
||||
(er-macro-transformer
|
||||
(lambda (form r c)
|
||||
`(,(r 'letrec-syntax) ,@(cdr form)))))
|
||||
|
||||
(export let let* letrec letrec*
|
||||
quasiquote unquote unquote-splicing
|
||||
and or
|
||||
cond case else =>
|
||||
do when unless
|
||||
let-syntax letrec-syntax
|
||||
include
|
||||
_ ... syntax-error))
|
||||
|
|
|
|||
|
|
@ -10,266 +10,8 @@
|
|||
begin
|
||||
define-syntax)
|
||||
|
||||
;; call/cc
|
||||
|
||||
(define real-callcc call-with-current-continuation)
|
||||
|
||||
(set! call-with-current-continuation
|
||||
(lambda (f)
|
||||
(real-callcc
|
||||
(lambda (c)
|
||||
(f (lambda args (apply continue c args)))))))
|
||||
|
||||
(define call/cc call-with-current-continuation)
|
||||
|
||||
(export call/cc)
|
||||
|
||||
;; core syntax
|
||||
|
||||
(define-syntax syntax-error
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(apply error (cdr expr)))))
|
||||
|
||||
(define-syntax define-auxiliary-syntax
|
||||
(er-macro-transformer
|
||||
(lambda (expr r c)
|
||||
(list (r 'define-syntax) (cadr expr)
|
||||
(list (r 'lambda) '_
|
||||
(list (r 'error) "invalid use of auxiliary syntax"))))))
|
||||
|
||||
(define-auxiliary-syntax else)
|
||||
(define-auxiliary-syntax =>)
|
||||
(define-auxiliary-syntax _)
|
||||
(define-auxiliary-syntax ...)
|
||||
(define-auxiliary-syntax unquote)
|
||||
(define-auxiliary-syntax unquote-splicing)
|
||||
|
||||
(define-syntax let
|
||||
(er-macro-transformer
|
||||
(lambda (expr r compare)
|
||||
(if (symbol? (cadr expr))
|
||||
(begin
|
||||
(define name (car (cdr expr)))
|
||||
(define bindings (car (cdr (cdr expr))))
|
||||
(define body (cdr (cdr (cdr expr))))
|
||||
(list (r 'let) '()
|
||||
(list (r 'define) name
|
||||
(cons (r 'lambda) (cons (map car bindings) body)))
|
||||
(cons name (map cadr bindings))))
|
||||
(begin
|
||||
(set! bindings (cadr expr))
|
||||
(set! body (cddr expr))
|
||||
(cons (cons (r 'lambda) (cons (map car bindings) body))
|
||||
(map cadr bindings)))))))
|
||||
|
||||
(define-syntax cond
|
||||
(er-macro-transformer
|
||||
(lambda (expr r compare)
|
||||
(let ((clauses (cdr expr)))
|
||||
(if (null? clauses)
|
||||
#f
|
||||
(begin
|
||||
(define clause (car clauses))
|
||||
(if (compare (r 'else) (car clause))
|
||||
(cons (r 'begin) (cdr clause))
|
||||
(if (if (>= (length clause) 2)
|
||||
(compare (r '=>) (list-ref clause 1))
|
||||
#f)
|
||||
(list (r 'let) (list (list (r 'x) (car clause)))
|
||||
(list (r 'if) (r 'x)
|
||||
(list (list-ref clause 2) (r 'x))
|
||||
(cons (r 'cond) (cdr clauses))))
|
||||
(list (r 'if) (car clause)
|
||||
(cons (r 'begin) (cdr clause))
|
||||
(cons (r 'cond) (cdr clauses)))))))))))
|
||||
|
||||
(define-syntax and
|
||||
(er-macro-transformer
|
||||
(lambda (expr r compare)
|
||||
(let ((exprs (cdr expr)))
|
||||
(cond
|
||||
((null? exprs)
|
||||
#t)
|
||||
((= (length exprs) 1)
|
||||
(car exprs))
|
||||
(else
|
||||
(list (r 'let) (list (list (r 'it) (car exprs)))
|
||||
(list (r 'if) (r 'it)
|
||||
(cons (r 'and) (cdr exprs))
|
||||
(r 'it)))))))))
|
||||
|
||||
(define-syntax or
|
||||
(er-macro-transformer
|
||||
(lambda (expr r compare)
|
||||
(let ((exprs (cdr expr)))
|
||||
(cond
|
||||
((null? exprs)
|
||||
#t)
|
||||
((= (length exprs) 1)
|
||||
(car exprs))
|
||||
(else
|
||||
(list (r 'let) (list (list (r 'it) (car exprs)))
|
||||
(list (r 'if) (r 'it)
|
||||
(r 'it)
|
||||
(cons (r 'or) (cdr exprs))))))))))
|
||||
|
||||
(define-syntax quasiquote
|
||||
(ir-macro-transformer
|
||||
(lambda (form inject compare)
|
||||
|
||||
(define (quasiquote? form)
|
||||
(and (pair? form) (compare (car form) 'quasiquote)))
|
||||
|
||||
(define (unquote? form)
|
||||
(and (pair? form) (compare (car form) 'unquote)))
|
||||
|
||||
(define (unquote-splicing? form)
|
||||
(and (pair? form) (pair? (car form))
|
||||
(compare (car (car form)) 'unquote-splicing)))
|
||||
|
||||
(define (qq depth expr)
|
||||
(cond
|
||||
;; unquote
|
||||
((unquote? expr)
|
||||
(if (= depth 1)
|
||||
(car (cdr expr))
|
||||
(list 'list
|
||||
(list 'quote (inject 'unquote))
|
||||
(qq (- depth 1) (car (cdr expr))))))
|
||||
;; unquote-splicing
|
||||
((unquote-splicing? expr)
|
||||
(if (= depth 1)
|
||||
(list 'append
|
||||
(car (cdr (car expr)))
|
||||
(qq depth (cdr expr)))
|
||||
(list 'cons
|
||||
(list 'list
|
||||
(list 'quote (inject 'unquote-splicing))
|
||||
(qq (- depth 1) (car (cdr (car expr)))))
|
||||
(qq depth (cdr expr)))))
|
||||
;; quasiquote
|
||||
((quasiquote? expr)
|
||||
(list 'list
|
||||
(list 'quote (inject 'quasiquote))
|
||||
(qq (+ depth 1) (car (cdr expr)))))
|
||||
;; list
|
||||
((pair? expr)
|
||||
(list 'cons
|
||||
(qq depth (car expr))
|
||||
(qq depth (cdr expr))))
|
||||
;; vector
|
||||
((vector? expr)
|
||||
(list 'list->vector (qq depth (vector->list expr))))
|
||||
;; simple datum
|
||||
(else
|
||||
(list 'quote expr))))
|
||||
|
||||
(let ((x (cadr form)))
|
||||
(qq 1 x)))))
|
||||
|
||||
(define-syntax let*
|
||||
(er-macro-transformer
|
||||
(lambda (form r compare)
|
||||
(let ((bindings (cadr form))
|
||||
(body (cddr form)))
|
||||
(if (null? bindings)
|
||||
`(,(r 'let) () ,@body)
|
||||
`(,(r 'let) ((,(caar bindings)
|
||||
,@(cdar bindings)))
|
||||
(,(r 'let*) (,@(cdr bindings))
|
||||
,@body)))))))
|
||||
|
||||
(define-syntax letrec*
|
||||
(er-macro-transformer
|
||||
(lambda (form r compare)
|
||||
(let ((bindings (cadr form))
|
||||
(body (cddr form)))
|
||||
(let ((vars (map (lambda (v) `(,v #f)) (map car bindings)))
|
||||
(initials (map (lambda (v) `(,(r 'set!) ,@v)) bindings)))
|
||||
`(,(r 'let) (,@vars)
|
||||
,@initials
|
||||
,@body))))))
|
||||
|
||||
(define-syntax letrec
|
||||
(er-macro-transformer
|
||||
(lambda (form rename compare)
|
||||
`(,(rename 'letrec*) ,@(cdr form)))))
|
||||
|
||||
(define-syntax do
|
||||
(er-macro-transformer
|
||||
(lambda (form r compare)
|
||||
(let ((bindings (car (cdr form)))
|
||||
(finish (car (cdr (cdr form))))
|
||||
(body (cdr (cdr (cdr form)))))
|
||||
`(,(r 'let) ,(r 'loop) ,(map (lambda (x)
|
||||
(list (car x) (cadr x)))
|
||||
bindings)
|
||||
(,(r 'if) ,(car finish)
|
||||
(,(r 'begin) ,@(cdr finish))
|
||||
(,(r 'begin) ,@body
|
||||
(,(r 'loop) ,@(map (lambda (x)
|
||||
(if (null? (cddr x))
|
||||
(car x)
|
||||
(car (cddr x))))
|
||||
bindings)))))))))
|
||||
|
||||
(define-syntax when
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let ((test (cadr expr))
|
||||
(body (cddr expr)))
|
||||
`(,(rename 'if) ,test
|
||||
(,(rename 'begin) ,@body)
|
||||
#f)))))
|
||||
|
||||
(define-syntax unless
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let ((test (cadr expr))
|
||||
(body (cddr expr)))
|
||||
`(,(rename 'if) ,test
|
||||
#f
|
||||
(,(rename 'begin) ,@body))))))
|
||||
|
||||
(define-syntax case
|
||||
(er-macro-transformer
|
||||
(lambda (expr r compare)
|
||||
(let ((key (cadr expr))
|
||||
(clauses (cddr expr)))
|
||||
`(,(r 'let) ((,(r 'key) ,key))
|
||||
,(let loop ((clauses clauses))
|
||||
(if (null? clauses)
|
||||
#f
|
||||
(begin
|
||||
(define clause (car clauses))
|
||||
`(,(r 'if) ,(if (compare (r 'else) (car clause))
|
||||
'#t
|
||||
`(,(r 'or)
|
||||
,@(map (lambda (x)
|
||||
`(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x)))
|
||||
(car clause))))
|
||||
,(if (compare (r '=>) (list-ref clause 1))
|
||||
`(,(list-ref clause 2) ,(r 'key))
|
||||
`(,(r 'begin) ,@(cdr clause)))
|
||||
,(loop (cdr clauses)))))))))))
|
||||
|
||||
(define-syntax letrec-syntax
|
||||
(er-macro-transformer
|
||||
(lambda (form r c)
|
||||
(let ((formal (car (cdr form)))
|
||||
(body (cdr (cdr form))))
|
||||
`(let ()
|
||||
,@(map (lambda (x)
|
||||
`(,(r 'define-syntax) ,(car x) ,(cadr x)))
|
||||
formal)
|
||||
,@body)))))
|
||||
|
||||
(define-syntax let-syntax
|
||||
(er-macro-transformer
|
||||
(lambda (form r c)
|
||||
`(,(r 'letrec-syntax) ,@(cdr form)))))
|
||||
|
||||
(import (scheme file))
|
||||
|
||||
(define-syntax include
|
||||
|
|
|
|||
Loading…
Reference in New Issue