conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

clean up code

This commit is contained in:
Yuito Murase 2014-04-03 15:30:42 +09:00
parent 85db821ad2
commit 7af2f1e11d
1 changed files with 294 additions and 308 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
piclib/syntax-rules.scm
View File

@ -1,10 +1,10 @@
(import (scheme base) (define-library (picrin syntax-rules)
(import (scheme base)
(scheme cxr) (scheme cxr)
(picrin macro) (picrin macro))
(scheme write))
;;; utility functions ;;; utility functions
(define (reverse* l) (define (reverse* l)
;; (reverse* '(a b c d . e)) => (e d c b a) ;; (reverse* '(a b c d . e)) => (e d c b a)
(let loop ((a '()) (let loop ((a '())
(d l)) (d l))
@ -12,21 +12,21 @@
(loop (cons (car d) a) (cdr d)) (loop (cons (car d) a) (cdr d))
(cons d a)))) (cons d a))))
(define (var->sym v) (define (var->sym v)
(let loop ((cnt 0) (let loop ((cnt 0)
(v v)) (v v))
(if (symbol? v) (if (symbol? v)
(string->symbol (string-append (symbol->string v) "/" (number->string cnt))) (string->symbol (string-append (symbol->string v) "/" (number->string cnt)))
(loop (+ 1 cnt) (car v))))) (loop (+ 1 cnt) (car v)))))
(define push-var list) (define push-var list)
(define (every? pred l) (define (every? pred l)
(if (null? l) (if (null? l)
#t #t
(and (pred (car l)) (every? pred (cdr l))))) (and (pred (car l)) (every? pred (cdr l)))))
(define (flatten l) (define (flatten l)
(cond (cond
((null? l) '()) ((null? l) '())
((pair? (car l)) ((pair? (car l))
@ -34,8 +34,8 @@
(else (else
(cons (car l) (flatten (cdr l)))))) (cons (car l) (flatten (cdr l))))))
;;; main function ;;; main function
(define-syntax syntax-rules (define-syntax syntax-rules
(er-macro-transformer (er-macro-transformer
(lambda (form r compare) (lambda (form r compare)
(define _define (r 'define)) (define _define (r 'define))
@ -188,7 +188,7 @@
#t) #t)
vars)))) vars))))
;;; compile expand ;;; compile expand
(define (compile-expand ellipsis reserved template) (define (compile-expand ellipsis reserved template)
(letrec ((compile-expand-base (letrec ((compile-expand-base
(lambda (template ellipsis-valid) (lambda (template ellipsis-valid)
@ -318,18 +318,4 @@
`(,_syntax-error "malformed syntax-rules")))))) `(,_syntax-error "malformed syntax-rules"))))))
;;; test code (export syntax-rules))
(import (scheme write))
(define-syntax hoge
(syntax-rules ()
((hoge (a ...) ...) '((a ...) ...))
((hoge (a b) ...) '(a ...))
((hoge a b ... c . d) 'c)))
(display (hoge (1 2 3) (3 4 5) (5 6 7)))
(newline)
(display (hoge (a b) (c d) (e f)))
(newline)
(display (hoge a b c))
(newline)