[plt-scheme] Can't see the tree for the forest
Jens Axel Søgaard
jensaxel at soegaard.net
Sun Jul 8 16:16:31 EDT 2007
Hi all,
As the title suggest I have a "Can't see the tree for the forest"
type of problem.
In the attached implementation of a simple begin-like control
construct with labels and gotos the last touch (aka error handling)
is bugging me.
I'd like a goto to an unknown label to give the error: "unknown label".
To do this I have collected all known label names with
(with-syntax ([(name1 ...)
(map name-of-label
(filter label?
(syntax->list #'((label start) label-or-expr ...))))])
In the goto macro (which expands (goto name) into (name), when
the name is known label, I want to check whether the
name is known or not. For some reason that escapes me,
the test
(srfi:member #'name (syntax->list #'(name1 ...)) module-identifier=?)
fails for both known and unknown label names.
In the attached file, the test has been replaced with #t in order
to test the rest.
What am I missing?
--
Jens Axel Søgaard
-------------- next part --------------
;;; begin-with-goto.scm -- Jens Axel Søgaard -- 7th July 2007
; This file implements a simple begin with gotos.
; For a more general version use tagged-begin.
; See the bottom of this file for examples.
#;(begin/goto
(label foo)
1
(label bar)
(goto foo))
; =>
#;(letrec ([foo (lambda ()
1
(goto bar))]
[bar (lambda ()
(goto foo))])
(foo))
(module begin-with-goto mzscheme
(provide begin/goto)
(require-for-syntax
(only (lib "1.ss" "srfi") take-while)
(only (lib "1.ss" "srfi") drop-while)
(only (lib "1.ss" "srfi") filter)
(prefix srfi: (lib "1.ss" "srfi"))
(lib "stx.ss" "syntax"))
(define-for-syntax (label? stx)
(syntax-case stx (label)
[(label label-name) #t]
[_else #f]))
(define-for-syntax (non-label? stx)
(not (label? stx)))
(define-for-syntax (first-label-and-block+more stx)
(syntax-case stx (label)
[((label label-name) label-or-expr ...)
(with-syntax ([(expr ...)
(let ([exprs
(take-while non-label?
(syntax->list #'(label-or-expr ...)))])
(if (null? exprs) (list #'(void)) exprs))]
[more
(drop-while non-label?
(syntax->list #'(label-or-expr ...)))])
(values #'(label-name (expr ...))
#'more))]))
(define-for-syntax (labels-and-exprs->blocks stx)
(syntax-case stx (label)
[() '()]
[_else (let-values ([(first more) (first-label-and-block+more stx)])
(cons first (labels-and-exprs->blocks more)))]))
(define-for-syntax (name-of-label stx)
(syntax-case stx (label)
[(label name) #'name]))
(define-for-syntax (error-check-begin/goto stx)
(syntax-case stx ()
[(_ label-or-expr ...)
(let* ([labels (filter label? (syntax->list #'(label-or-expr ...)))]
[names (map name-of-label labels)])
; Are all labels identifiers?
(for-each (lambda (name)
(unless (identifier? name)
(raise-syntax-error 'begin/goto
"labels must be identifiers" name)))
names)
; Are the duplicate labels?
(cond
[(check-duplicate-identifier names)
=> (lambda (name)
(raise-syntax-error 'begin/goto
"duplicate label found: "
name))]))]))
(define-syntax (begin/goto stx)
(error-check-begin/goto stx)
(syntax-case stx (label)
[(_)
#'(void)]
[(_ (label start) label-or-expr ...)
(with-syntax ([((label-name (expr ... last-expr)) ... (end-label-name (end-expr ...)))
(labels-and-exprs->blocks #'((label start) label-or-expr ...))])
(with-syntax ([(next-label ...)
(cdr (syntax->list #'(label-name ... end-label-name)))])
(with-syntax ([(continue ...)
(map (lambda (last-expr next-label)
(syntax-case last-expr (goto)
[(goto name) last-expr]
[_else #`(begin #,last-expr (#,next-label))]))
(syntax->list #'(last-expr ...))
(syntax->list #'(next-label ...)))])
(with-syntax ([(name1 ...)
(map name-of-label
(filter label? (syntax->list #'((label start) label-or-expr ...))))])
(with-syntax ([goto (syntax-local-introduce #'goto)])
(syntax/loc stx
(let-syntax ([goto
(lambda (stx)
(syntax-case stx (goto)
[(_ name)
(begin
(unless (identifier? #'name)
(raise-syntax-error 'goto "identifier expected" #'name))
(cond
[#t #;(srfi:member #'name (syntax->list #'(name1 ...)) module-identifier=?)
(syntax/loc stx
(name))]
[else
(raise-syntax-error 'goto "unknown label" stx)]))]
[_else
(raise-syntax-error 'goto "expected (goto <label>), got" stx)]))])
(letrec ([label-name (lambda () expr ... continue)]
...
[end-label-name (lambda () end-expr ...)])
(start)))))))))]
[(_ expr label-or-expr ...)
(syntax/loc stx
(begin/goto (label start) expr label-or-expr ...))]))
)
(require begin-with-goto)
(require (planet "78.ss" ("soegaard" "srfi.plt")))
(check (begin/goto) => (void))
(check (begin/goto 1) => 1)
(check (begin/goto 1 2) => 2)
(check (begin/goto 1 2 3) => 3)
(check (begin/goto (label l1)) => (void))
(check (begin/goto (label l1) 1) => 1)
(check (begin/goto (label l1) 1 2) => 2)
(check (begin/goto (label l1) (label l2)) => (void))
(check (begin/goto (label l1) (label l2) 1) => 1)
(check (begin/goto (label l1) (label l2) 1 2) => 2)
(check (begin/goto (goto l1) (label l1)) => (void))
(check (begin/goto (goto l1) (label l1) 1) => 1)
(check (begin/goto (goto l1) (label l1) 1 2) => 2)
(check (begin/goto (goto l1) 3 (label l1)) => (void))
(check (begin/goto (goto l1) 3 (label l1) 1) => 1)
(check (begin/goto (goto l1) 3 (label l1) 1 2) => 2)
(check (begin/goto (goto l1) (label l2) (label l1)) => (void))
(check (begin/goto (goto l1) (label l2) (label l1) 1) => 1)
(check (begin/goto (goto l1) (label l2) (label l1) 1 2) => 2)
(check (begin/goto (label l2) (label l1)) => (void))
(check (begin/goto (label l2) (label l1) 1) => 1)
(check (begin/goto (label l2) (label l1) 1 2) => 2)
(check (begin/goto (label l2) (goto l1) (label l1)) => (void))
(check (begin/goto (label l2) (goto l1) (label l1) 1) => 1)
(check (begin/goto (label l2) (goto l1) (label l1) 1 2) => 2)
(check (let ([x 1])
(begin/goto (label l1)
(set! x (+ x 1))
(if (= x 10000)
(goto l2) ; sadly not tail-recursive (use tagged-begin instead)
(goto l1))
(label l2)
x))
=> 10000)
(check (let ([x 1])
(let/ec return
(begin/goto
(label l1)
(set! x (+ x 1))
(if (= x 10000000)
(return x))
(goto l1)))) ; this is tail-recursive
=> 10000000)
#;
(check (let ([x 1])
(let/ec return
(begin/goto
(label l1)
(set! x (+ x 1))
(if (= x 10000000)
(return x))
(goto l1)
2 ; this will become tail-recursive in next version
)))
=> 10000000)
;; The following must raise syntax errors
;(begin/goto (label dup) (label dup)) ; duplicate label
;(begin/goto (goto l1)) ; non-existing label
(check-report)
More information about the plt-scheme
mailing list