Re: Guile Lua

[Ian Price <ianprice90@googlemail.com>]

[-- Attachment #1: Type: text/plain, Size: 734 bytes --]

Stefan Israelsson Tampe <stefan.itampe@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"


[-- Attachment #2: tagbody --]
[-- Type: text/plain, Size: 1327 bytes --]

(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)))))))])))

)

[-- Attachment #3: various utilities --]
[-- Type: text/plain, Size: 1434 bytes --]

(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)))

)