-
-
Save evhan/9f12c6c17968f0f8f929 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
(import (scheme base) (scheme write) (scheme cxr)) | |
(cond-expand | |
(chibi (import (chibi) (chibi match))) | |
(sagittarius (import (sagittarius) (match))) | |
(gauche (import (gauche base) (util match))) | |
(chicken (import-for-syntax (matchable))) | |
(else #t)) | |
(cond-expand | |
((and chicken csi) ; when run with `csi -R r7rs -s tagged.scm` | |
(import (matchable))) | |
(else #t)) | |
;; simple identifier-syntax | |
(define-syntax identifier-syntax | |
(er-macro-transformer | |
(lambda (f r c) | |
(match f | |
((_ e) | |
(let ((.f (r 'form)) | |
(.r (r 'rename)) | |
(.c (r 'compare))) | |
`(,(r 'er-macro-transformer) | |
(,(r 'lambda) (,.f ,.r ,.c) | |
(,(r 'match) ,.f | |
((? symbol? id) ',e) | |
((_ x ...) `(,',e ,@x))))))))))) | |
(define (make-tagged-variable-transformer tag-id src-var-id) | |
(er-macro-transformer | |
(lambda (f r c) | |
(let ((TAG (r tag-id)) | |
(SRC-VAR (r src-var-id))) | |
(match f | |
((??var . ??stuff) | |
`(,TAG dispatch: ,SRC-VAR (,(r ??var) . ,(map r ??stuff)))) | |
;; how to check if this ??var is identifier/symbol | |
;; should er-macro have identifier? procedure? | |
(??var src-var-id)))))) | |
(cond-expand | |
((or chibi chicken) | |
;; Chicken has a problem on syntax-rules. | |
;; Chibi has a problem with define-with-caller. | |
;; so just make it like this for good sake. | |
(define (parse-let-bindings bindings-stx rename compare top-id . rest) | |
(let ((vars (if (null? rest) '() (car rest))) | |
(tags (if (null? rest) '() (cadr rest))) | |
(syntax-bindings (if (null? rest) '() (caddr rest)))) | |
(match bindings-stx | |
(() | |
(list (reverse vars) (reverse tags) (reverse syntax-bindings))) | |
(((?var ?tag) . ?other-bindings) | |
(let ((tag-id (rename ?tag))) | |
(parse-let-bindings ?other-bindings rename compare top-id | |
(cons (rename ?var) vars) | |
(cons tag-id tags) | |
(if (compare tag-id top-id) | |
syntax-bindings | |
(cons `(,?var | |
(make-tagged-variable-transformer ',tag-id | |
',(rename ?var))) | |
syntax-bindings))))) | |
(_ | |
(error "parse-let-bindings: invalid bindings syntax" bindings-stx))))) | |
) | |
(else | |
(define-syntax %define-inline | |
(syntax-rules () | |
((_ (?name ?arg ... . ?rest) ?form0 ?form ...) | |
(define-syntax ?name | |
(syntax-rules () | |
((_ ?arg ... . ?rest) | |
(begin ?form0 ?form ...))))))) | |
(define-syntax define-with-caller | |
(er-macro-transformer | |
(lambda (f r c) | |
(define (rename* expr) | |
(cond ((null? expr) expr) | |
((pair? expr) | |
(cons (rename* (car expr)) | |
(rename* (cdr expr)))) | |
((vector? expr) | |
(list->vector (rename* (vector->list expr)))) | |
((string? expr) expr) | |
(else (r expr)))) | |
(match f | |
((_ (?who (?caller-arg ...) ((?func-arg ?func-default) ...)) | |
?body0 ?body ...) | |
(let ((FUNCTION (r (string->symbol "dummy")))) | |
`(,(r 'begin) | |
(,(r 'define) (,FUNCTION ,@?caller-arg ,@?func-arg) | |
(,(r 'let-syntax) ((,?who (,(r 'identifier-syntax) ,FUNCTION))) | |
,?body0 | |
,@?body)) | |
(,(r '%define-inline) (,?who ,@?caller-arg) | |
(,FUNCTION ,@?caller-arg ,@?func-default))))))))) | |
(define-with-caller (parse-let-bindings (bindings-stx rename compare top-id) | |
((vars '()) | |
(tags '()) | |
(syntax-bindings '()))) | |
(match bindings-stx | |
(() | |
(list (reverse vars) (reverse tags) (reverse syntax-bindings))) | |
(((?var ?tag) . ?other-bindings) | |
(let ((tag-id (rename ?tag))) | |
(parse-let-bindings ?other-bindings rename compare top-id | |
(cons (rename ?var) vars) | |
(cons tag-id tags) | |
(if (compare tag-id top-id) | |
syntax-bindings | |
(cons `(,?var | |
(make-tagged-variable-transformer ',tag-id | |
',(rename ?var))) | |
syntax-bindings))))) | |
(_ | |
(error "parse-let-bindings: invalid bindings syntax" bindings-stx)))) | |
)) | |
(define-syntax with-tags | |
(er-macro-transformer | |
(lambda (f r c) | |
(define (rename* expr) | |
(cond ((null? expr) expr) | |
((pair? expr) | |
(cons (rename* (car expr)) | |
(rename* (cdr expr)))) | |
((vector? expr) | |
(list->vector (rename* (vector->list expr)))) | |
(else (r expr)))) | |
(match f | |
((_ (?var ...) ?body0 ?body ...) | |
(match (parse-let-bindings (rename* ?var) r c (r '<top>)) | |
(((VAR ...) (TAG ...) (SYNTAX-BINDING ...)) | |
`(,(r 'let-syntax) (,@SYNTAX-BINDING) | |
,(rename* ?body0) | |
,@(rename* ?body))))))))) | |
(define-syntax <beta> | |
(er-macro-transformer | |
(lambda (f r c) | |
(match f | |
((_ 'dispatch: src (var . stuff)) | |
(display 'dispatched!) (newline) (r src)))))) | |
(define (beta-def-ref o) | |
(with-tags ((o <beta>)) | |
(list (o d) (o e) (o f)))) | |
(beta-def-ref 'a) | |
;; (a a a) | |
(define (beta-def-ref2 o) | |
(with-tags ((oo <beta>)) | |
(list (oo d) (oo e) (oo f)))) | |
;; -> error |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment