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

Added syntax-rules

Browse source
This commit is contained in:
Justin Ethier 2016-02-12 22:16:18 -05:00
parent 5f1ff0af16
commit 08ead45b5a
1 changed files with 239 additions and 239 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

478
scheme/base.sld
View file

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