mirror of
https://github.com/justinethier/cyclone.git
synced 2025-05-23 20:15:05 +02:00
Added syntax-rules
This commit is contained in:
Justin Ethier
parent
5f1ff0af16
commit
08ead45b5a
1 changed files with 239 additions and 239 deletions
478
scheme/base.sld
478
scheme/base.sld
|
|
@ -1,8 +1,8 @@
|
|||
(define-library (scheme base)
|
||||
;; In the future, may include this here: (include "../srfi/9.scm")
|
||||
(export
|
||||
; cons-source
|
||||
; syntax-rules
|
||||
cons-source
|
||||
syntax-rules
|
||||
; TODO: need filter for the next two. also, they really belong in SRFI-1, not here
|
||||
;delete
|
||||
;delete-duplicates
|
||||
|
|
@ -1044,241 +1044,241 @@
|
|||
(p->mode == 0 && p->fp != NULL) ? boolean_t : boolean_f); ")
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; syntax-rules
|
||||
;(define identifier? symbol?)
|
||||
;(define (identifier->symbol obj) obj)
|
||||
;(define (find-tail pred ls)
|
||||
; (and (pair? ls) (if (pred (car ls)) ls (find-tail pred (cdr ls)))))
|
||||
;
|
||||
;(define (find pred ls)
|
||||
; (cond ((find-tail pred ls) => car) (else #f)))
|
||||
;(define (cons-source kar kdr source)
|
||||
; (cons kar kdr))
|
||||
;
|
||||
;(define-syntax syntax-rules
|
||||
; (er-macro-transformer
|
||||
; (lambda (expr rename compare)
|
||||
; (let ((ellipsis-specified? (identifier? (cadr expr)))
|
||||
; (count 0)
|
||||
; (_er-macro-transformer (rename 'er-macro-transformer))
|
||||
; (_lambda (rename 'lambda)) (_let (rename 'let))
|
||||
; (_begin (rename 'begin)) (_if (rename 'if))
|
||||
; (_and (rename 'and)) (_or (rename 'or))
|
||||
; (_eq? (rename 'eq?)) (_equal? (rename 'equal?))
|
||||
; (_car (rename 'car)) (_cdr (rename 'cdr))
|
||||
; (_cons (rename 'cons)) (_pair? (rename 'pair?))
|
||||
; (_null? (rename 'null?)) (_expr (rename 'expr))
|
||||
; (_rename (rename 'rename)) (_compare (rename 'compare))
|
||||
; (_quote (rename 'quote)) (_apply (rename 'apply))
|
||||
; ;(_quote (rename 'syntax-quote)) (_apply (rename 'apply))
|
||||
; (_append (rename 'append)) (_map (rename 'map))
|
||||
; (_vector? (rename 'vector?)) (_list? (rename 'list?))
|
||||
; (_len (rename'len)) (_length (rename 'length))
|
||||
; (_- (rename '-)) (_>= (rename '>=)) (_error (rename 'error))
|
||||
; (_ls (rename 'ls)) (_res (rename 'res)) (_i (rename 'i))
|
||||
; (_reverse (rename 'reverse))
|
||||
; (_vector->list (rename 'vector->list))
|
||||
; (_list->vector (rename 'list->vector))
|
||||
; (_cons3 (rename 'cons-source)))
|
||||
; (define ellipsis (rename (if ellipsis-specified? (cadr expr) '...)))
|
||||
; (define lits (if ellipsis-specified? (car (cddr expr)) (cadr expr)))
|
||||
; (define forms (if ellipsis-specified? (cdr (cddr expr)) (cddr expr)))
|
||||
; (define (next-symbol s)
|
||||
; (set! count (+ count 1))
|
||||
; (rename (string->symbol (string-append s (number->string count)))))
|
||||
; (define (expand-pattern pat tmpl)
|
||||
; (let lp ((p (cdr pat))
|
||||
; (x (list _cdr _expr))
|
||||
; (dim 0)
|
||||
; (vars '())
|
||||
; (k (lambda (vars)
|
||||
; (list _cons (expand-template tmpl vars) #f))))
|
||||
; (let ((v (next-symbol "v.")))
|
||||
; (list
|
||||
; _let (list (list v x))
|
||||
; (cond
|
||||
; ((identifier? p)
|
||||
; (if (any (lambda (l) (compare p l)) lits)
|
||||
; (list _and
|
||||
; (list _compare v (list _rename (list _quote p)))
|
||||
; (k vars))
|
||||
; (list _let (list (list p v)) (k (cons (cons p dim) vars)))))
|
||||
; ((ellipsis? p)
|
||||
; (cond
|
||||
; ((not (null? (cdr (cdr p))))
|
||||
; (cond
|
||||
; ((any (lambda (x) (and (identifier? x) (compare x ellipsis)))
|
||||
; (cddr p))
|
||||
; (error "multiple ellipses" p))
|
||||
; (else
|
||||
; (let ((len (length (cdr (cdr p))))
|
||||
; (_lp (next-symbol "lp.")))
|
||||
; `(,_let ((,_len (,_length ,v)))
|
||||
; (,_and (,_>= ,_len ,len)
|
||||
; (,_let ,_lp ((,_ls ,v)
|
||||
; (,_i (,_- ,_len ,len))
|
||||
; (,_res (,_quote ())))
|
||||
; (,_if (,_>= 0 ,_i)
|
||||
; ,(lp `(,(cddr p)
|
||||
; (,(car p) ,(car (cdr p))))
|
||||
; `(,_cons ,_ls
|
||||
; (,_cons (,_reverse ,_res)
|
||||
; (,_quote ())))
|
||||
; dim
|
||||
; vars
|
||||
; k)
|
||||
; (,_lp (,_cdr ,_ls)
|
||||
; (,_- ,_i 1)
|
||||
; (,_cons3 (,_car ,_ls)
|
||||
; ,_res
|
||||
; ,_ls))))))))))
|
||||
; ((identifier? (car p))
|
||||
; (list _and (list _list? v)
|
||||
; (list _let (list (list (car p) v))
|
||||
; (k (cons (cons (car p) (+ 1 dim)) vars)))))
|
||||
; (else
|
||||
; (let* ((w (next-symbol "w."))
|
||||
; (_lp (next-symbol "lp."))
|
||||
; (new-vars (all-vars (car p) (+ dim 1)))
|
||||
; (ls-vars (map (lambda (x)
|
||||
; (next-symbol
|
||||
; (string-append
|
||||
; (symbol->string
|
||||
; (identifier->symbol (car x)))
|
||||
; "-ls")))
|
||||
; new-vars))
|
||||
; (once
|
||||
; (lp (car p) (list _car w) (+ dim 1) '()
|
||||
; (lambda (_)
|
||||
; (cons
|
||||
; _lp
|
||||
; (cons
|
||||
; (list _cdr w)
|
||||
; (map (lambda (x l)
|
||||
; (list _cons (car x) l))
|
||||
; new-vars
|
||||
; ls-vars)))))))
|
||||
; (list
|
||||
; _let
|
||||
; _lp (cons (list w v)
|
||||
; (map (lambda (x) (list x (list _quote '()))) ls-vars))
|
||||
; (list _if (list _null? w)
|
||||
; (list _let (map (lambda (x l)
|
||||
; (list (car x) (list _reverse l)))
|
||||
; new-vars
|
||||
; ls-vars)
|
||||
; (k (append new-vars vars)))
|
||||
; (list _and (list _pair? w) once)))))))
|
||||
; ((pair? p)
|
||||
; (list _and (list _pair? v)
|
||||
; (lp (car p)
|
||||
; (list _car v)
|
||||
; dim
|
||||
; vars
|
||||
; (lambda (vars)
|
||||
; (lp (cdr p) (list _cdr v) dim vars k)))))
|
||||
; ((vector? p)
|
||||
; (list _and
|
||||
; (list _vector? v)
|
||||
; (lp (vector->list p) (list _vector->list v) dim vars k)))
|
||||
; ((null? p) (list _and (list _null? v) (k vars)))
|
||||
; (else (list _and (list _equal? v p) (k vars))))))))
|
||||
; (define (ellipsis-escape? x) (and (pair? x) (compare ellipsis (car x))))
|
||||
; (define (ellipsis? x)
|
||||
; (and (pair? x) (pair? (cdr x)) (compare ellipsis (cadr x))))
|
||||
; (define (ellipsis-depth x)
|
||||
; (if (ellipsis? x)
|
||||
; (+ 1 (ellipsis-depth (cdr x)))
|
||||
; 0))
|
||||
; (define (ellipsis-tail x)
|
||||
; (if (ellipsis? x)
|
||||
; (ellipsis-tail (cdr x))
|
||||
; (cdr x)))
|
||||
; (define (all-vars x dim)
|
||||
; (let lp ((x x) (dim dim) (vars '()))
|
||||
; (cond ((identifier? x)
|
||||
; (if (any (lambda (lit) (compare x lit)) lits)
|
||||
; vars
|
||||
; (cons (cons x dim) vars)))
|
||||
; ((ellipsis? x) (lp (car x) (+ dim 1) (lp (cddr x) dim vars)))
|
||||
; ((pair? x) (lp (car x) dim (lp (cdr x) dim vars)))
|
||||
; ((vector? x) (lp (vector->list x) dim vars))
|
||||
; (else vars))))
|
||||
; (define (free-vars x vars dim)
|
||||
; (let lp ((x x) (free '()))
|
||||
; (cond
|
||||
; ((identifier? x)
|
||||
; (if (and (not (memq x free))
|
||||
; (cond ((assq x vars) => (lambda (cell) (>= (cdr cell) dim)))
|
||||
; (else #f)))
|
||||
; (cons x free)
|
||||
; free))
|
||||
; ((pair? x) (lp (car x) (lp (cdr x) free)))
|
||||
; ((vector? x) (lp (vector->list x) free))
|
||||
; (else free))))
|
||||
; (define (expand-template tmpl vars)
|
||||
; (let lp ((t tmpl) (dim 0))
|
||||
; (cond
|
||||
; ((identifier? t)
|
||||
; (cond
|
||||
; ((find (lambda (v) (compare t (car v))) vars)
|
||||
; => (lambda (cell)
|
||||
; (if (<= (cdr cell) dim)
|
||||
; t
|
||||
; (error "too few ...'s"))))
|
||||
; (else
|
||||
; (list _rename (list _quote t)))))
|
||||
; ((pair? t)
|
||||
; (cond
|
||||
; ((ellipsis-escape? t)
|
||||
; (list _quote
|
||||
; (if (pair? (cdr t))
|
||||
; (if (pair? (cddr t)) (cddr t) (cadr t))
|
||||
; (cdr t))))
|
||||
; ((ellipsis? t)
|
||||
; (let* ((depth (ellipsis-depth t))
|
||||
; (ell-dim (+ dim depth))
|
||||
; (ell-vars (free-vars (car t) vars ell-dim)))
|
||||
; (cond
|
||||
; ((null? ell-vars)
|
||||
; (error "too many ...'s"))
|
||||
; ((and (null? (cdr (cdr t))) (identifier? (car t)))
|
||||
; ;; shortcut for (var ...)
|
||||
; (lp (car t) ell-dim))
|
||||
; (else
|
||||
; (let* ((once (lp (car t) ell-dim))
|
||||
; (nest (if (and (null? (cdr ell-vars))
|
||||
; (identifier? once)
|
||||
; (eq? once (car vars)))
|
||||
; once ;; shortcut
|
||||
; (cons _map
|
||||
; (cons (list _lambda ell-vars once)
|
||||
; ell-vars))))
|
||||
; (many (do ((d depth (- d 1))
|
||||
; (many nest
|
||||
; (list _apply _append many)))
|
||||
; ((= d 1) many))))
|
||||
; (if (null? (ellipsis-tail t))
|
||||
; many ;; shortcut
|
||||
; (list _append many (lp (ellipsis-tail t) dim))))))))
|
||||
; (else (list _cons3 (lp (car t) dim) (lp (cdr t) dim) (list _quote t)))))
|
||||
; ((vector? t) (list _list->vector (lp (vector->list t) dim)))
|
||||
; ((null? t) (list _quote '()))
|
||||
; (else t))))
|
||||
; (list
|
||||
; _er-macro-transformer
|
||||
; (list _lambda (list _expr _rename _compare)
|
||||
; (list
|
||||
; _car
|
||||
; (cons
|
||||
; _or
|
||||
; (append
|
||||
; (map
|
||||
; (lambda (clause) (expand-pattern (car clause) (cadr clause)))
|
||||
; forms)
|
||||
; (list
|
||||
; (list _cons
|
||||
; (list _error "no expansion for"
|
||||
; _expr ; (list (rename 'strip-syntactic-closures) _expr)
|
||||
; )
|
||||
; #f)))))))))))
|
||||
(define identifier? symbol?)
|
||||
(define (identifier->symbol obj) obj)
|
||||
(define (find-tail pred ls)
|
||||
(and (pair? ls) (if (pred (car ls)) ls (find-tail pred (cdr ls)))))
|
||||
|
||||
(define (find pred ls)
|
||||
(cond ((find-tail pred ls) => car) (else #f)))
|
||||
(define (cons-source kar kdr source)
|
||||
(cons kar kdr))
|
||||
|
||||
(define-syntax syntax-rules
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let ((ellipsis-specified? (identifier? (cadr expr)))
|
||||
(count 0)
|
||||
(_er-macro-transformer (rename 'er-macro-transformer))
|
||||
(_lambda (rename 'lambda)) (_let (rename 'let))
|
||||
(_begin (rename 'begin)) (_if (rename 'if))
|
||||
(_and (rename 'and)) (_or (rename 'or))
|
||||
(_eq? (rename 'eq?)) (_equal? (rename 'equal?))
|
||||
(_car (rename 'car)) (_cdr (rename 'cdr))
|
||||
(_cons (rename 'cons)) (_pair? (rename 'pair?))
|
||||
(_null? (rename 'null?)) (_expr (rename 'expr))
|
||||
(_rename (rename 'rename)) (_compare (rename 'compare))
|
||||
(_quote (rename 'quote)) (_apply (rename 'apply))
|
||||
;(_quote (rename 'syntax-quote)) (_apply (rename 'apply))
|
||||
(_append (rename 'append)) (_map (rename 'map))
|
||||
(_vector? (rename 'vector?)) (_list? (rename 'list?))
|
||||
(_len (rename'len)) (_length (rename 'length))
|
||||
(_- (rename '-)) (_>= (rename '>=)) (_error (rename 'error))
|
||||
(_ls (rename 'ls)) (_res (rename 'res)) (_i (rename 'i))
|
||||
(_reverse (rename 'reverse))
|
||||
(_vector->list (rename 'vector->list))
|
||||
(_list->vector (rename 'list->vector))
|
||||
(_cons3 (rename 'cons-source)))
|
||||
(define ellipsis (rename (if ellipsis-specified? (cadr expr) '...)))
|
||||
(define lits (if ellipsis-specified? (car (cddr expr)) (cadr expr)))
|
||||
(define forms (if ellipsis-specified? (cdr (cddr expr)) (cddr expr)))
|
||||
(define (next-symbol s)
|
||||
(set! count (+ count 1))
|
||||
(rename (string->symbol (string-append s (number->string count)))))
|
||||
(define (expand-pattern pat tmpl)
|
||||
(let lp ((p (cdr pat))
|
||||
(x (list _cdr _expr))
|
||||
(dim 0)
|
||||
(vars '())
|
||||
(k (lambda (vars)
|
||||
(list _cons (expand-template tmpl vars) #f))))
|
||||
(let ((v (next-symbol "v.")))
|
||||
(list
|
||||
_let (list (list v x))
|
||||
(cond
|
||||
((identifier? p)
|
||||
(if (any (lambda (l) (compare p l)) lits)
|
||||
(list _and
|
||||
(list _compare v (list _rename (list _quote p)))
|
||||
(k vars))
|
||||
(list _let (list (list p v)) (k (cons (cons p dim) vars)))))
|
||||
((ellipsis? p)
|
||||
(cond
|
||||
((not (null? (cdr (cdr p))))
|
||||
(cond
|
||||
((any (lambda (x) (and (identifier? x) (compare x ellipsis)))
|
||||
(cddr p))
|
||||
(error "multiple ellipses" p))
|
||||
(else
|
||||
(let ((len (length (cdr (cdr p))))
|
||||
(_lp (next-symbol "lp.")))
|
||||
`(,_let ((,_len (,_length ,v)))
|
||||
(,_and (,_>= ,_len ,len)
|
||||
(,_let ,_lp ((,_ls ,v)
|
||||
(,_i (,_- ,_len ,len))
|
||||
(,_res (,_quote ())))
|
||||
(,_if (,_>= 0 ,_i)
|
||||
,(lp `(,(cddr p)
|
||||
(,(car p) ,(car (cdr p))))
|
||||
`(,_cons ,_ls
|
||||
(,_cons (,_reverse ,_res)
|
||||
(,_quote ())))
|
||||
dim
|
||||
vars
|
||||
k)
|
||||
(,_lp (,_cdr ,_ls)
|
||||
(,_- ,_i 1)
|
||||
(,_cons3 (,_car ,_ls)
|
||||
,_res
|
||||
,_ls))))))))))
|
||||
((identifier? (car p))
|
||||
(list _and (list _list? v)
|
||||
(list _let (list (list (car p) v))
|
||||
(k (cons (cons (car p) (+ 1 dim)) vars)))))
|
||||
(else
|
||||
(let* ((w (next-symbol "w."))
|
||||
(_lp (next-symbol "lp."))
|
||||
(new-vars (all-vars (car p) (+ dim 1)))
|
||||
(ls-vars (map (lambda (x)
|
||||
(next-symbol
|
||||
(string-append
|
||||
(symbol->string
|
||||
(identifier->symbol (car x)))
|
||||
"-ls")))
|
||||
new-vars))
|
||||
(once
|
||||
(lp (car p) (list _car w) (+ dim 1) '()
|
||||
(lambda (_)
|
||||
(cons
|
||||
_lp
|
||||
(cons
|
||||
(list _cdr w)
|
||||
(map (lambda (x l)
|
||||
(list _cons (car x) l))
|
||||
new-vars
|
||||
ls-vars)))))))
|
||||
(list
|
||||
_let
|
||||
_lp (cons (list w v)
|
||||
(map (lambda (x) (list x (list _quote '()))) ls-vars))
|
||||
(list _if (list _null? w)
|
||||
(list _let (map (lambda (x l)
|
||||
(list (car x) (list _reverse l)))
|
||||
new-vars
|
||||
ls-vars)
|
||||
(k (append new-vars vars)))
|
||||
(list _and (list _pair? w) once)))))))
|
||||
((pair? p)
|
||||
(list _and (list _pair? v)
|
||||
(lp (car p)
|
||||
(list _car v)
|
||||
dim
|
||||
vars
|
||||
(lambda (vars)
|
||||
(lp (cdr p) (list _cdr v) dim vars k)))))
|
||||
((vector? p)
|
||||
(list _and
|
||||
(list _vector? v)
|
||||
(lp (vector->list p) (list _vector->list v) dim vars k)))
|
||||
((null? p) (list _and (list _null? v) (k vars)))
|
||||
(else (list _and (list _equal? v p) (k vars))))))))
|
||||
(define (ellipsis-escape? x) (and (pair? x) (compare ellipsis (car x))))
|
||||
(define (ellipsis? x)
|
||||
(and (pair? x) (pair? (cdr x)) (compare ellipsis (cadr x))))
|
||||
(define (ellipsis-depth x)
|
||||
(if (ellipsis? x)
|
||||
(+ 1 (ellipsis-depth (cdr x)))
|
||||
0))
|
||||
(define (ellipsis-tail x)
|
||||
(if (ellipsis? x)
|
||||
(ellipsis-tail (cdr x))
|
||||
(cdr x)))
|
||||
(define (all-vars x dim)
|
||||
(let lp ((x x) (dim dim) (vars '()))
|
||||
(cond ((identifier? x)
|
||||
(if (any (lambda (lit) (compare x lit)) lits)
|
||||
vars
|
||||
(cons (cons x dim) vars)))
|
||||
((ellipsis? x) (lp (car x) (+ dim 1) (lp (cddr x) dim vars)))
|
||||
((pair? x) (lp (car x) dim (lp (cdr x) dim vars)))
|
||||
((vector? x) (lp (vector->list x) dim vars))
|
||||
(else vars))))
|
||||
(define (free-vars x vars dim)
|
||||
(let lp ((x x) (free '()))
|
||||
(cond
|
||||
((identifier? x)
|
||||
(if (and (not (memq x free))
|
||||
(cond ((assq x vars) => (lambda (cell) (>= (cdr cell) dim)))
|
||||
(else #f)))
|
||||
(cons x free)
|
||||
free))
|
||||
((pair? x) (lp (car x) (lp (cdr x) free)))
|
||||
((vector? x) (lp (vector->list x) free))
|
||||
(else free))))
|
||||
(define (expand-template tmpl vars)
|
||||
(let lp ((t tmpl) (dim 0))
|
||||
(cond
|
||||
((identifier? t)
|
||||
(cond
|
||||
((find (lambda (v) (compare t (car v))) vars)
|
||||
=> (lambda (cell)
|
||||
(if (<= (cdr cell) dim)
|
||||
t
|
||||
(error "too few ...'s"))))
|
||||
(else
|
||||
(list _rename (list _quote t)))))
|
||||
((pair? t)
|
||||
(cond
|
||||
((ellipsis-escape? t)
|
||||
(list _quote
|
||||
(if (pair? (cdr t))
|
||||
(if (pair? (cddr t)) (cddr t) (cadr t))
|
||||
(cdr t))))
|
||||
((ellipsis? t)
|
||||
(let* ((depth (ellipsis-depth t))
|
||||
(ell-dim (+ dim depth))
|
||||
(ell-vars (free-vars (car t) vars ell-dim)))
|
||||
(cond
|
||||
((null? ell-vars)
|
||||
(error "too many ...'s"))
|
||||
((and (null? (cdr (cdr t))) (identifier? (car t)))
|
||||
;; shortcut for (var ...)
|
||||
(lp (car t) ell-dim))
|
||||
(else
|
||||
(let* ((once (lp (car t) ell-dim))
|
||||
(nest (if (and (null? (cdr ell-vars))
|
||||
(identifier? once)
|
||||
(eq? once (car vars)))
|
||||
once ;; shortcut
|
||||
(cons _map
|
||||
(cons (list _lambda ell-vars once)
|
||||
ell-vars))))
|
||||
(many (do ((d depth (- d 1))
|
||||
(many nest
|
||||
(list _apply _append many)))
|
||||
((= d 1) many))))
|
||||
(if (null? (ellipsis-tail t))
|
||||
many ;; shortcut
|
||||
(list _append many (lp (ellipsis-tail t) dim))))))))
|
||||
(else (list _cons3 (lp (car t) dim) (lp (cdr t) dim) (list _quote t)))))
|
||||
((vector? t) (list _list->vector (lp (vector->list t) dim)))
|
||||
((null? t) (list _quote '()))
|
||||
(else t))))
|
||||
(list
|
||||
_er-macro-transformer
|
||||
(list _lambda (list _expr _rename _compare)
|
||||
(list
|
||||
_car
|
||||
(cons
|
||||
_or
|
||||
(append
|
||||
(map
|
||||
(lambda (clause) (expand-pattern (car clause) (cadr clause)))
|
||||
forms)
|
||||
(list
|
||||
(list _cons
|
||||
(list _error "no expansion for"
|
||||
_expr ; (list (rename 'strip-syntactic-closures) _expr)
|
||||
)
|
||||
#f)))))))))))
|
||||
))
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue