Stefan Israelsson Tampe <stefan.ita...@gmail.com> writes:
> To note is that in order to implement common lisp one need to bypass tree-il
> and generate directly to glil, the reason is that tagbody is poorly
> represented
> by tree-il. If we intend to be multilingual it would be nice to be able to
> effectively
> represent those ideoms. Any thoughts on it?
At one point I implemented tagbody for a laugh using call/cc. I've
attached the code, but it's kinda lame. I was much less experienced with
continuations and macros then, and I could certainly write it better now.
--
Ian Price -- shift-reset.com
"Programming is like pinball. The reward for doing it well is
the opportunity to do it again" - from "The Wizardy Compiled"
(library (tagbody)
(export tagbody go)
(import (rnrs)
(for (tagbody utils) expand)
(for (srfi :8 receive) expand))
(define (go tag)
(tag #f))
(define-syntax tagbody
(lambda (stx)
(define (make-group tag statements next)
#`(call/cc
(lambda (escape)
(call/cc
(lambda (k)
(set! #,tag k)
(escape k)))
#,@statements
#,(if next
#`(go #,next)
#'#f))))
(define (exprs->groups first-tag list)
(unzip (plist->alist identifier?
(cons first-tag list))))
(syntax-case stx ()
[(tagbody tags-or-statements ...)
(let ((init #'init))
(receive (tags groups) (exprs->groups
init
(syntax->list #'(tags-or-statements ...)))
(with-syntax (((entry-point ...) (generate-temporaries tags))
((tag ...) tags)
((group ...)
(map make-group tags groups (shift-left tags #f))))
#`(let ((tag #f) ... (done #f))
(let ((entry-point group) ...)
(unless done
(set! done #t)
(go #,init)))))))])))
)
(library (tagbody utils)
(export plist->alist
shift-left
unzip
syntax->list
)
(import (rnrs))
(define (syntax->list stxobj)
(define (inner stx)
(syntax-case stx ()
[() '()]
[(x . rest)
(cons #'x (inner #'rest))]))
(assert (list? (syntax->datum stxobj)))
(inner stxobj))
(define (plist->alist car? plist)
;; assumes head of (car? plist) is true
(define (rcons a b)
(cons (reverse a) b))
(if (null? plist)
'()
(let loop ((plist (cdr plist))
(current-field (list (car plist)))
(return-list '()))
(cond ((null? plist)
(reverse
(if (null? current-field)
return-list
(rcons current-field return-list))))
((car? (car plist))
(loop (cdr plist)
(list (car plist))
(rcons current-field return-list)))
(else
(loop (cdr plist)
(cons (car plist) current-field)
return-list))))))
(define (unzip list-of-pairs)
(let loop ((pairs list-of-pairs) (cars '()) (cdrs '()))
(if (null? pairs)
(values (reverse cars) (reverse cdrs))
(loop (cdr pairs) (cons (caar pairs) cars)
(cons (cdar pairs) cdrs)))))
(define (shift-left old-list end)
(append (cdr old-list) (list end)))
)
