Skip to content

Instantly share code, notes, and snippets.


okuoku/wrk.scm Secret

Created May 20, 2018
What would you like to do?
(define (yuni/gensym bogus) (gensym))
(define (yuni/identifier? x) (symbol? x))
(define (yuni/any1 pred l)
(and (pair? l)
(pred (car l))
(yuni/any1 pred (cdr l))))
(define (yuni/find1 pred l)
(if (pair? l)
(let ((a (car l)))
(if (pred a)
(yuni/find1 pred (cdr l))))
;; Took from chibi-scheme 22f87f67ab24d42fe0872cb5ceea6ecafe8933ad
;; init-7.scm -- core library procedures for R7RS
;; Copyright (c) 2009-2012 Alex Shinn. All rights reserved.
;; BSD-style license:
;; syntax-rules
;; YUNI: Added 4th argument `baselib` to non-rename injector
;; `rename` can be a `gensym` procedure
(define (yuni/syntax-rules-transformer expr rename baselib compare)
(let ((ellipsis-specified? (yuni/identifier? (cadr expr)))
(count 0)
(_er-macro-transformer (baselib 'yuni/er-macro-transformer4))
(_lambda (baselib 'lambda)) (_let (baselib 'let))
(_begin (baselib 'begin)) (_if (baselib 'if))
(_and (baselib 'and)) (_or (baselib 'or))
(_eq? (baselib 'eq?)) (_equal? (baselib 'equal?))
(_car (baselib 'car)) (_cdr (baselib 'cdr))
(_cons (baselib 'cons)) (_pair? (baselib 'pair?))
(_null? (baselib 'null?)) (_expr (rename 'expr))
(_rename (rename 'rename)) (_compare (rename 'compare))
;; YUNI: _quote can be a quote for us ... perhaps
(_quote (baselib 'quote)) (_apply (baselib 'apply))
(_append (baselib 'append)) (_map (baselib 'map))
(_vector? (baselib 'vector?)) (_list? (baselib 'list?))
(_len (rename 'len)) (_length (baselib 'yuni/length*))
(_- (rename '-)) (_>= (baselib '>=)) (_error (baselib 'error))
(_ls (rename 'ls)) (_res (rename 'res)) (_i (rename 'i))
(_reverse (baselib 'reverse))
(_vector->list (baselib 'vector->list))
(_list->vector (baselib 'list->vector))
(_cons3 (baselib 'yuni/cons-source))
(_underscore (baselib '_))
;; YUNI: Additional procedures
(_baselib (rename 'baselib))
(identifier? yuni/identifier?) (length* yuni/length*)
(find yuni/find1)
(any yuni/any1)
(%number->string number->string))
(define ellipsis (if ellipsis-specified? (cadr expr) (baselib '...)))
(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.")))
_let (list (list v x))
((identifier? p)
((ellipsis-mark? p)
(error "bad ellipsis" p))
((memq p lits)
(list _and
;; FIXME: _rename => _baselib
(list _compare v (list _baselib (list _quote p)))
(k vars)))
((compare p _underscore)
(k vars))
(list _let (list (list p v)) (k (cons (cons p dim) vars))))))
((ellipsis? p)
((not (null? (cdr (cdr p))))
((any (lambda (x) (and (identifier? x) (ellipsis-mark? x)))
(cddr p))
(error "multiple ellipses" p))
(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 ())))
(,_lp (,_cdr ,_ls)
(,_- ,_i 1)
(,_cons3 (,_car ,_ls)
((identifier? (car p))
(list _and (list _list? v)
(list _let (list (list (car p) v))
(k (cons (cons (car p) (+ 1 dim)) vars)))))
(let* ((w (next-symbol "w."))
(_lp (next-symbol "lp."))
(new-vars (all-vars (car p) (+ dim 1)))
(ls-vars (map (lambda (x)
(identifier->symbol (car x)))
(lp (car p) (list _car w) (+ dim 1) '()
(lambda (_)
(list _cdr w)
(map (lambda (x l)
(list _cons (car x) l))
_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)))
(k (append new-vars vars)))
(list _and (list _pair? w) once)))))))
((pair? p)
(list _and (list _pair? v)
(lp (car p)
(list _car v)
(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-mark?
(if (if ellipsis-specified?
(memq ellipsis lits)
(any (lambda (x) (compare ellipsis x)) lits))
(lambda (x) #f)
(if ellipsis-specified?
(lambda (x) (eq? ellipsis x))
(lambda (x) (compare ellipsis x)))))
(define (ellipsis-escape? x) (and (pair? x) (ellipsis-mark? (car x))))
(define (ellipsis? x)
(and (pair? x) (pair? (cdr x)) (ellipsis-mark? (cadr x))))
(define (ellipsis-depth x)
(if (ellipsis? x)
(+ 1 (ellipsis-depth (cdr x)))
(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 (or (memq x lits)
(compare x _underscore))
(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 '()))
((identifier? x)
(if (and (not (memq x free))
;(cond ((assq x vars) => (lambda (cell) (>= (cdr cell) dim)))
; (else #f))
(let ((cell (assq x vars)))
(and cell
(>= (cdr cell) dim))))
(cons x 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))
((identifier? t)
; ((find (lambda (v) (eq? t (car v))) vars)
; => (lambda (cell)
; (if (<= (cdr cell) dim)
; t
; (error "too few ...'s"))))
; (else
; (list _baselib (list _quote t))))
(let ((cell (find (lambda (v) (eq? t (car v))) vars)))
(if cell
(if (<= (cdr cell) dim)
(error "two few ...'s"))
(list _baselib (list _quote t)))))
((pair? t)
((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)))
((null? ell-vars)
(error "too many ...'s"))
((and (null? (cdr (cdr t))) (identifier? (car t)))
;; shortcut for (var ...)
(lp (car t) ell-dim))
(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)
(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 _lambda (list _expr _rename _baselib _compare)
(lambda (clause) (expand-pattern (car clause) (cadr clause)))
(list _cons
(list _error "no expansion for"
(list _expr))
;; Generic syntax-rules implementation for define-macro platforms
;; Runtime for chibi-scheme's synrule implementation
;; yuni/gensym and yuni/identifier? are implementation specific
(define (yuni/cons-source a b c) (cons a b))
(define (yuni/length*-itr n obj)
(if (pair? obj)
(yuni/length*-itr (+ n 1) (cdr obj))
(define (yuni/length* obj)
(yuni/length*-itr 0 obj))
(define (yuni/synrule-baselib sym) sym)
(define (yuni/synrule-compare x y) (eq? x y))
(define-macro (define-syntax name synrule)
(let ((tran
yuni/gensym yuni/synrule-baselib yuni/synrule-compare)))
(args (yuni/gensym 'args)))
`(define-macro (,name . ,args)
(,tran (cons ',name ,args)
yuni/gensym yuni/synrule-baselib yuni/synrule-compare))))
(define-syntax checkelse
(syntax-rules (else)
((_ else) (display "Is Else\n"))
((_ otherwise) (display "Is NOT Else\n"))))
(checkelse else)
(checkelse if)
(let ((else #t))
(checkelse else))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment