Moved from PLaneT to pkg.racket-lang.org
This commit is contained in:
Jens Axel Søgaard
parent
41b78ccd74
commit
6624de6389
240
control/begin-with-goto.rkt
Normal file
240
control/begin-with-goto.rkt
Normal file
|
|
@ -0,0 +1,240 @@
|
|||
#lang racket
|
||||
(provide begin/goto)
|
||||
|
||||
;;; 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))
|
||||
|
||||
#;(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"))
|
||||
|
||||
(require (for-syntax racket/list syntax/stx))
|
||||
|
||||
|
||||
(define-for-syntax (label? stx)
|
||||
(syntax-case stx (label)
|
||||
[(label label-name) #t]
|
||||
[_else #f]))
|
||||
|
||||
(define-for-syntax (goto? stx)
|
||||
(syntax-case stx (goto)
|
||||
[(goto 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
|
||||
(takef (syntax->list #'(label-or-expr ...))
|
||||
non-label?)])
|
||||
(if (null? exprs) (list #'(void)) exprs))]
|
||||
[more
|
||||
(dropf (syntax->list #'(label-or-expr ...))
|
||||
non-label?)])
|
||||
(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-for-syntax (introduce-labels-after-goto stx)
|
||||
(syntax-case stx (goto label)
|
||||
[((goto label-name) (label label-name1) label-or-expr ...)
|
||||
(with-syntax ([((goto label-name) (label label-name1) label-or-expr ...)
|
||||
stx])
|
||||
(with-syntax ([(label-or-expr ...)
|
||||
(introduce-labels-after-goto
|
||||
#'(label-or-expr ...))])
|
||||
(syntax/loc stx
|
||||
((goto label-name) (label label-name1) label-or-expr ...))))]
|
||||
[((goto label-name) expr label-or-expr ...)
|
||||
(with-syntax ([((goto label-name) expr label-or-expr ...) stx])
|
||||
(with-syntax ([(lab) (generate-temporaries (list #'lab))])
|
||||
(introduce-labels-after-goto
|
||||
(syntax/loc stx
|
||||
((goto label-name) (label lab) expr label-or-expr ...)))))]
|
||||
[(label-or-expr1 label-or-expr ...)
|
||||
(with-syntax ([(label-or-expr ...)
|
||||
(introduce-labels-after-goto
|
||||
#'(label-or-expr ...))])
|
||||
(syntax/loc stx
|
||||
(label-or-expr1 label-or-expr ...)))]
|
||||
[_else
|
||||
stx]))
|
||||
|
||||
|
||||
(define-syntax (begin/goto stx)
|
||||
(error-check-begin/goto stx)
|
||||
(syntax-case stx (label)
|
||||
[(_)
|
||||
#'(void)]
|
||||
[(_ (label start) label-or-expr ...)
|
||||
(with-syntax ([(label-or-expr ...)
|
||||
(introduce-labels-after-goto #'(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
|
||||
(letrec-syntaxes+values
|
||||
([(goto) (lambda (stx)
|
||||
(syntax-case stx (goto)
|
||||
[(_ name)
|
||||
(begin
|
||||
(unless (identifier? #'name)
|
||||
(raise-syntax-error 'goto "identifier expected" #'name))
|
||||
(cond
|
||||
[(memf (λ(x)
|
||||
; was module-identifier=?
|
||||
(module-or-top-identifier=? x #'name))
|
||||
(syntax->list #'(name1 ...)))
|
||||
(syntax/loc stx
|
||||
(name))]
|
||||
[else
|
||||
(raise-syntax-error 'goto "unknown label" stx)]))]
|
||||
[_else
|
||||
(raise-syntax-error 'goto "expected (goto <label>), got" stx)]))])
|
||||
([(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")))
|
||||
;
|
||||
|
||||
(module+ test (require rackunit)
|
||||
|
||||
(check-equal? (begin/goto) (void))
|
||||
(check-equal? (begin/goto 1) 1)
|
||||
(check-equal? (begin/goto 1 2) 2)
|
||||
(check-equal? (begin/goto 1 2 3) 3)
|
||||
|
||||
(check-equal? (begin/goto (label l1)) (void))
|
||||
(check-equal? (begin/goto (label l1) 1) 1)
|
||||
(check-equal? (begin/goto (label l1) 1 2) 2)
|
||||
|
||||
(check-equal? (begin/goto (label l1) (label l2)) (void))
|
||||
(check-equal? (begin/goto (label l1) (label l2) 1) 1)
|
||||
(check-equal? (begin/goto (label l1) (label l2) 1 2) 2)
|
||||
|
||||
(check-equal? (begin/goto (goto l1) (label l1)) (void))
|
||||
(check-equal? (begin/goto (goto l1) (label l1) 1) 1)
|
||||
(check-equal? (begin/goto (goto l1) (label l1) 1 2) 2)
|
||||
|
||||
(check-equal? (begin/goto (goto l1) 3 (label l1)) (void))
|
||||
(check-equal? (begin/goto (goto l1) 3 (label l1) 1) 1)
|
||||
(check-equal? (begin/goto (goto l1) 3 (label l1) 1 2) 2)
|
||||
|
||||
(check-equal? (begin/goto (goto l1) (label l2) (label l1)) (void))
|
||||
(check-equal? (begin/goto (goto l1) (label l2) (label l1) 1) 1)
|
||||
(check-equal? (begin/goto (goto l1) (label l2) (label l1) 1 2) 2)
|
||||
|
||||
(check-equal? (begin/goto (label l2) (label l1)) (void))
|
||||
(check-equal? (begin/goto (label l2) (label l1) 1) 1)
|
||||
(check-equal? (begin/goto (label l2) (label l1) 1 2) 2)
|
||||
|
||||
(check-equal? (begin/goto (label l2) (goto l1) (label l1)) (void))
|
||||
(check-equal? (begin/goto (label l2) (goto l1) (label l1) 1) 1)
|
||||
(check-equal? (begin/goto (label l2) (goto l1) (label l1) 1 2) 2)
|
||||
|
||||
(check-equal? (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-equal? (let ([x 1])
|
||||
(let/ec return
|
||||
(begin/goto
|
||||
(label l1)
|
||||
(set! x (+ x 1))
|
||||
(when (= x 10000000)
|
||||
(return x))
|
||||
(goto l1)))) ; this is tail-recursive
|
||||
10000000)
|
||||
|
||||
(check-equal? (let ([x 1])
|
||||
(let/ec return
|
||||
(begin/goto
|
||||
(label l1)
|
||||
(set! x (+ x 1))
|
||||
(when (= x 10000000)
|
||||
(return x))
|
||||
(goto l1) ; unless this is tail-recursice, the stack will blow
|
||||
2
|
||||
)))
|
||||
10000000)
|
||||
|
||||
;; The following must raise syntax errors
|
||||
;(begin/goto (label dup) (label dup)) ; duplicate label
|
||||
;(begin/goto (goto l1)) ; non-existing label
|
||||
)
|
||||
40
control/dotimes.rkt
Normal file
40
control/dotimes.rkt
Normal file
|
|
@ -0,0 +1,40 @@
|
|||
#lang racket
|
||||
(provide dotimes)
|
||||
|
||||
(require (for-syntax syntax/parse))
|
||||
|
||||
; macro: (dotimes (var expr [finally]) body ...)
|
||||
; dotimes iterates over a series of integers.
|
||||
; dotimes evaluates expr and signals an error if the result
|
||||
; is not an integer. If expr is zero or negative, the
|
||||
; body is not executed. Otherwiese dotimes executed the body
|
||||
; for each integer from 0 up to but not including the value of expr.
|
||||
; During the evaluation of body, var is bound to each integer.
|
||||
; Then finally is evaluated if present, and the result is returned,
|
||||
; otherwise #void is returned. At the time finally is evaluated,
|
||||
; var is bound to the number of times body was excuted.
|
||||
|
||||
(define-syntax (dotimes stx)
|
||||
(syntax-parse stx
|
||||
[(_dotimes (var count-form finally) body ...)
|
||||
#`(let ([count count-form])
|
||||
(unless (integer? count)
|
||||
(raise-syntax-error 'dotimes
|
||||
(format "expected integer as result of expression, got ~s " count)
|
||||
#'count-form))
|
||||
(if (positive? count)
|
||||
(let ([var 0])
|
||||
(let loop ([i 0])
|
||||
(set! var i)
|
||||
(if (< i count)
|
||||
(let ()
|
||||
body ...
|
||||
(loop (add1 i)))
|
||||
finally)))
|
||||
(let ([var 0])
|
||||
finally)))]
|
||||
[(_dotimes (var count-form) body ...)
|
||||
#'(dotimes (var count-form (void)) body ...)]
|
||||
[_
|
||||
(raise-syntax-error
|
||||
#f "bad syntax, (dotimes (var expr [finally-expr]) body ...) expected" stx)]))
|
||||
11
control/info.rkt
Normal file
11
control/info.rkt
Normal file
|
|
@ -0,0 +1,11 @@
|
|||
#lang setup/infotab
|
||||
(define name "Control")
|
||||
(define blurb
|
||||
(list "Control Structures: while, until, begin/goto, tagbody, dotimes"))
|
||||
(define scribblings '(["scribblings/control-manual.scrbl"]))
|
||||
(define categories '(devtools))
|
||||
(define version "3.0")
|
||||
(define primary-file "main.rkt")
|
||||
(define compile-omit-paths '("tests" "scribblings"))
|
||||
(define release-notes (list))
|
||||
;(define repositories '("4.x"))
|
||||
12
control/main.rkt
Normal file
12
control/main.rkt
Normal file
|
|
@ -0,0 +1,12 @@
|
|||
#lang racket
|
||||
(require "dotimes.rkt"
|
||||
"tagged-begin.rkt"
|
||||
"until.rkt"
|
||||
"while.rkt"
|
||||
"begin-with-goto.rkt")
|
||||
|
||||
(provide dotimes
|
||||
tagged-begin
|
||||
until
|
||||
while
|
||||
begin/goto)
|
||||
213
control/scribblings/control-manual.scrbl
Normal file
213
control/scribblings/control-manual.scrbl
Normal file
|
|
@ -0,0 +1,213 @@
|
|||
#lang scribble/doc
|
||||
|
||||
@(require scribble/manual
|
||||
scribble/eval
|
||||
control
|
||||
(for-label racket control))
|
||||
|
||||
@defmodule[control]
|
||||
|
||||
@title{Control}
|
||||
|
||||
@index{control}
|
||||
@index{CL}
|
||||
@index{tagbody}
|
||||
@index{knuth}
|
||||
@index{go}
|
||||
@index{return}
|
||||
@index{loop}
|
||||
@index{iteration}
|
||||
@index{goto}
|
||||
@index{label}
|
||||
|
||||
@section{History}
|
||||
|
||||
Version 2.0
|
||||
|
||||
- added documentation in Scribble form
|
||||
|
||||
Version 1.1
|
||||
|
||||
- added @scheme[begin/goto]
|
||||
|
||||
Version 1.0
|
||||
|
||||
- initial version, available control structures:
|
||||
@scheme[while], @scheme[until], @scheme[dotimes], and @scheme[tagged-begin]
|
||||
|
||||
|
||||
@section{Control Structures}
|
||||
|
||||
@defform[(while test body)]{
|
||||
|
||||
Syntax: @scheme[_test] should be an expression and @scheme[_body] a
|
||||
sequence of one or more expressions.
|
||||
|
||||
Semantics: @scheme[while] is an iteration construct. Each iteration begins by
|
||||
evaluating the @scheme[_test] expression. If it evaluates to a
|
||||
true value, the @scheme[_body] expressions are evaluated
|
||||
sequentially from left to right, then the next iteration
|
||||
begins. If the @scheme[_test] expression evaluates to false then
|
||||
iteration stops and an unspecified value is returned
|
||||
as the result of the while-expression.
|
||||
|
||||
Example: @interaction[
|
||||
(require control)
|
||||
(let ([n 3] [sum 0])
|
||||
(while (> n 0)
|
||||
(set! sum (+ sum n))
|
||||
(set! n (- n 1)))
|
||||
sum)]
|
||||
}
|
||||
|
||||
@defform[(until test body)]{
|
||||
|
||||
Syntax: @scheme[_test] should be an expression and @scheme[_body] a
|
||||
sequence of one or more expressions.
|
||||
|
||||
Semantics: @scheme[until] is an iteration construct. Each iteration
|
||||
begins by evaluating the @scheme[_body] expressions
|
||||
sequentially from left to right. The @scheme[_test]
|
||||
expression is then evaluated. If the result is
|
||||
a true value, then the next iteration begins.
|
||||
Otherwise the iteration stops and unspecified
|
||||
value is returned as the result of the
|
||||
until-expression.
|
||||
|
||||
Example: @interaction[
|
||||
(require control)
|
||||
(let ([n 3] [sum 0])
|
||||
(until (= n 1)
|
||||
(set! sum (+ sum n))
|
||||
(set! n (- n 1)))
|
||||
sum)]
|
||||
}
|
||||
|
||||
@defform[(dotimes (variable expression [finally]) body)]{
|
||||
|
||||
Syntax: @scheme[_variable] should be an identifier, @scheme[_expression]
|
||||
and @scheme[_finally] (if present) should be expressions and
|
||||
@scheme[_body] a sequence of one or more expressions.
|
||||
|
||||
Semantics: @scheme[dotimes] is an iteration contructs. Evalutations begins
|
||||
by evaluating @scheme[_expression]. If the result is not an
|
||||
integer an error is signaled. If the result is zero or
|
||||
negative, the @scheme[_body] expressions are not evaluated.
|
||||
Otherwise the @scheme[_body] expressions are evaluated for each
|
||||
integer from 0 up to but not including the result of
|
||||
@scheme[_expression].
|
||||
|
||||
During each evaluation of the @scheme[_body] expressions,
|
||||
@scheme[_variable] is bound to each integer.
|
||||
|
||||
When the iteration stops @scheme[_finally] is evaluated if
|
||||
present and the result returned, otherwise @schemeresult[void] is
|
||||
returned. During evaluation of @scheme[_finally]
|
||||
the @scheme[_variable] is bound to the number of times the
|
||||
body were evaluated.
|
||||
|
||||
Examples: @interaction[
|
||||
(require control)
|
||||
|
||||
(let ((xs '()))
|
||||
(dotimes (x 5)
|
||||
(set! xs (cons x xs)))
|
||||
xs)
|
||||
|
||||
(let ((xs '()))
|
||||
(dotimes (x 5 (list xs x))
|
||||
(set! xs (cons x xs))))]
|
||||
}
|
||||
|
||||
@defform[(tagged-begin (tag / expression)* )]{
|
||||
|
||||
Syntax: @scheme[_tag] should be a symbol, and all @scheme[_tag]s should be different.
|
||||
|
||||
Motivation: The macro @scheme[tagged-begin] is inspired by the Common Lisp
|
||||
construct @schemeid[tagbody].
|
||||
|
||||
Semantics: The @scheme[tagged-begin] expression evaluates the expressions
|
||||
in a lexical environment, where @scheme[go] and @scheme[return] are
|
||||
are bound to functions of one argument, which will
|
||||
transfer control when called.
|
||||
|
||||
As main rule the expressions will be evaluated sequentially
|
||||
from left to right. When there are no more expressions to
|
||||
be evaluated @schemeresult[void] is returned.
|
||||
|
||||
If an expression evaluates (go @scheme[_tag] then control is transfered
|
||||
to the expression following the tag. The tags have lexical scope.
|
||||
The dynamic extent of tag is indefinite. An @scheme[(go tag)] is allowed to
|
||||
tranfer control to an outer tagged-begin. The call @scheme[(go tag)] has the
|
||||
proper tail recursive property, even in situation where the call
|
||||
syntactically is not in tail position.
|
||||
|
||||
If @scheme[(return _expression)] is evaluted, the value of @scheme[_expression] is
|
||||
returned as the value of the entire @scheme[tagged-begin] form.
|
||||
|
||||
Examples: @interaction[
|
||||
(require control)
|
||||
(let ([i 0])
|
||||
(tagged-begin
|
||||
loop (set! i (+ i 1))
|
||||
(when (< i 41) (go loop)))
|
||||
i)
|
||||
|
||||
(let ([odd-numbers '()]
|
||||
[a 0])
|
||||
(tagged-begin
|
||||
start (set! a 0)
|
||||
on-odd (set! a (+ a 1))
|
||||
(set! odd-numbers (cons a odd-numbers))
|
||||
(cond
|
||||
[(>= a 9) (go end)]
|
||||
[(even? a) (go on-even)]
|
||||
[else (go on-odd)])
|
||||
on-even (set! a (+ a 1))
|
||||
(go on-odd)
|
||||
end)
|
||||
odd-numbers)]
|
||||
|
||||
References: "Applications of Continuations" of Daniel P. Friedman.
|
||||
}
|
||||
|
||||
@defform[(begin/goto label-or-goto-or-expression* )]{
|
||||
|
||||
Syntax: @scheme[_label-or-goto-or-expression] is
|
||||
either @scheme[(label _identifier)]
|
||||
or @scheme[(goto _identifier)]
|
||||
or @scheme[_expression].
|
||||
|
||||
Motivation: Think of @scheme[begin/goto] as a normal @scheme[begin], where
|
||||
@scheme[goto] can be used to jump to a control point
|
||||
named by a label. An @scheme[(goto _identifier)] will
|
||||
transfer control to the point named by the identifier.
|
||||
If the @scheme[goto-form] is one of the @scheme[_label-or-goto-expression],
|
||||
then a goto doesn't grow the control context.
|
||||
|
||||
Examples:
|
||||
|
||||
@interaction[
|
||||
(require control)
|
||||
(let ([x 1])
|
||||
(let/ec return
|
||||
(begin/goto
|
||||
(label l1)
|
||||
(set! x (+ x 1))
|
||||
(when (= x 10000000)
|
||||
(return x))
|
||||
(goto l1)))) ; this is tail-recursive
|
||||
|
||||
(let ([x 1])
|
||||
(let/ec return
|
||||
(begin/goto
|
||||
(label l1)
|
||||
(set! x (+ x 1))
|
||||
(when (= x 10000000)
|
||||
(return x))
|
||||
(goto l1) ; this is tail-recursive
|
||||
2
|
||||
)))]
|
||||
}
|
||||
|
||||
@index-section{}
|
||||
254
control/tagged-begin.rkt
Normal file
254
control/tagged-begin.rkt
Normal file
|
|
@ -0,0 +1,254 @@
|
|||
#lang racket
|
||||
(provide tagged-begin)
|
||||
|
||||
;;; INTRODUCTION
|
||||
|
||||
; This is a little macro that resembles the Common Lisp tagbody construct
|
||||
; <http://www-2.cs.cmu.edu/Groups/AI/html/hyperspec/HyperSpec/Body/speope_tagbody.html#tagbody>
|
||||
; See also "Applications of Continuations" of Daniel P. Friedman.
|
||||
|
||||
;;; MOTIVATION
|
||||
|
||||
; Many algorithms is specified in an imperative manner
|
||||
; in the literature [See Example 5 from Knuth]. For a no-brain-
|
||||
; conversion to Scheme tagged-begin is convenient.
|
||||
|
||||
;;; SYNTAX
|
||||
|
||||
; (tagged-begin
|
||||
; (<tag> | <expression>)* )
|
||||
|
||||
; where <tag> is a symbol and duplicate tags are not allowed.
|
||||
|
||||
|
||||
;;; SEMANTICS
|
||||
|
||||
; The form evaluates the expressions in a lexical environment
|
||||
; that provides functions go and return both of one argument to
|
||||
; transfer control.
|
||||
|
||||
; The expressions in tagged-begin are evaluated sequentially.
|
||||
; If no expressions are left (void) is returned.
|
||||
|
||||
; If an expression evaluates (go tag) then control is transfered
|
||||
; to the expression following tag. The tags have lexical scope.
|
||||
; The dynamic extent of tag is indefinite. An (go tag) is allowed
|
||||
; to tranfer control to an outer tagbody. The call (go tag) has the
|
||||
; proper tail recursive property, even in situation where the call
|
||||
; syntactically is not in tail position.
|
||||
|
||||
; If (return <expression>) is evaluted, the value of <expression> is
|
||||
; the value of the entire tagged-begin form.
|
||||
|
||||
|
||||
;;; EXAMPLES
|
||||
|
||||
; See below the implementation.
|
||||
|
||||
;;; IMPLEMENTATION
|
||||
|
||||
; Tagged begin is here implemented as a syntax-case macro.
|
||||
; The rewrite rule is taken from Daniel P. Friedmans
|
||||
; "Applications of Continuations".
|
||||
|
||||
|
||||
; (tagged-begin
|
||||
; tag_1 e1 ... ; If the body doesn't begin with a tag
|
||||
; ... ; the macro inserts a fresh one
|
||||
; tag_n-1 e_n-1 ...
|
||||
; tag_n en ...)
|
||||
|
||||
; expands to
|
||||
|
||||
; ((let/cc go
|
||||
; (let ([return (lambda (v) (go (lambda () v)))])
|
||||
; (letrec
|
||||
; ([tag_1 (lambda () e1 ... (tag2))]
|
||||
; ...
|
||||
; [tag_n-1 (lambda () e_n-1 ... (tag_n))]
|
||||
; [tag_n (lambda () e_n ... (return (void)))]
|
||||
; (tag_1))))))
|
||||
|
||||
; where (let/cc k expr ...) is short for (call/cc (lambda (k) expr ...)))]))
|
||||
|
||||
(require (for-syntax syntax/parse racket/list racket/match))
|
||||
|
||||
(define-syntax (tagged-begin stx)
|
||||
(define tag? identifier?)
|
||||
(define (non-tag? o) (not (tag? o)))
|
||||
|
||||
(define (generate-binding tag-exprs next-tag)
|
||||
(match tag-exprs
|
||||
[(list tag exprs) (quasisyntax/loc stx [#,tag (lambda () #,@exprs (#,next-tag))])]))
|
||||
|
||||
(define (generate-last-binding tag-exprs return)
|
||||
(match tag-exprs
|
||||
[(list tag exprs) (quasisyntax/loc stx [#,tag (lambda () #,@exprs (#,return (void)))])]))
|
||||
|
||||
(syntax-case stx ()
|
||||
[(tagged-begin . tag/exprs-stx)
|
||||
(let ([tes (syntax->list #'tag/exprs-stx)])
|
||||
; introduce a dummy start-tag, if the tagged-begin starts with an expression
|
||||
(when (not (tag? (car tes)))
|
||||
(set! tes (cons #'start tes)))
|
||||
(let* ([first-tag (car tes)]
|
||||
[tag-exprs-list (let loop ([tes tes]
|
||||
[rev-result '()])
|
||||
(if (null? tes)
|
||||
(reverse rev-result)
|
||||
(let ([p tes])
|
||||
(if (tag? (car p))
|
||||
(loop (cdr tes)
|
||||
(cons (list (car p) (takef (cdr p) non-tag?))
|
||||
rev-result))
|
||||
(loop (cdr tes)
|
||||
rev-result)
|
||||
))))
|
||||
#;(list-ec (:pairs p tes)
|
||||
(if (tag? (car p)))
|
||||
(list (car p) (take-while non-tag? (cdr p))))
|
||||
]
|
||||
[tags (map car tag-exprs-list)])
|
||||
; tag-exprs-list = ( (tag_1 (e1 ...)) (tag_2 (e2 ...)) ... )
|
||||
(with-syntax ([go (syntax-local-introduce (syntax/loc stx go))]
|
||||
[return (syntax-local-introduce (syntax/loc stx return))])
|
||||
#`((let/cc go
|
||||
(let ([return (lambda (v) (go (lambda () v)))])
|
||||
(letrec
|
||||
(#,@(map generate-binding
|
||||
(drop-right tag-exprs-list 1)
|
||||
(cdr tags))
|
||||
#,(generate-last-binding (last tag-exprs-list) #'return))
|
||||
(#,first-tag))))))))]))
|
||||
|
||||
(module+ test (require rackunit))
|
||||
|
||||
(module+ test
|
||||
; Example 1 (tagged-begin returns (void))
|
||||
(check-equal?
|
||||
(let ([i 0])
|
||||
(tagged-begin
|
||||
loop (set! i (+ i 1))
|
||||
(when (< i 41) (go loop)))
|
||||
i)
|
||||
41)
|
||||
; Example 2 (tagged-begin returns 42)
|
||||
(check-equal?
|
||||
(let ([i 0])
|
||||
(tagged-begin
|
||||
loop (set! i (+ i 1))
|
||||
(when (< i 42) (go loop))
|
||||
(return i)))
|
||||
42)
|
||||
; Example 3 (tagged-begin returns 43)
|
||||
(check-equal?
|
||||
(let ([i 0])
|
||||
(tagged-begin
|
||||
loop (set! i (+ i 1))
|
||||
(go b)
|
||||
a (when (< i 43) (go loop))
|
||||
(return i)
|
||||
b (go a)))
|
||||
43)
|
||||
; Example 4 ( <http://www.emacswiki.org/cgi-bin/wiki.pl?StateMachine> )
|
||||
(define (example4)
|
||||
(let ((a 0))
|
||||
(tagged-begin
|
||||
start
|
||||
(set! a 0)
|
||||
part-1
|
||||
(set! a (+ a 1))
|
||||
(displayln a)
|
||||
(cond
|
||||
((>= a 9) (go end))
|
||||
((even? a) (go part-1))
|
||||
(else (go part-2)))
|
||||
part-2
|
||||
(set! a (+ a 1))
|
||||
(go part-1)
|
||||
end
|
||||
(displayln "We're done printing the odd numbers between 0 and 10"))))
|
||||
; Example 5 ( Knuth: "The Art of Computer Programming", vol1, p.176)
|
||||
|
||||
; Inplace inversion of a permutation represented as a vector.
|
||||
|
||||
(define permutation (vector 'dummy 6 2 1 5 4 3)) ; (Knuth counts from 1 not 0 :-) )
|
||||
(define n (- (vector-length permutation) 1))
|
||||
(define (X i) (vector-ref permutation i))
|
||||
(define (X! i j) (vector-set! permutation i j))
|
||||
|
||||
(let ([m 0] [i 0] [j 0])
|
||||
(tagged-begin
|
||||
I1 ; Initialize
|
||||
(set! m n)
|
||||
(set! j -1)
|
||||
I2 ; Next element
|
||||
(set! i (X m))
|
||||
(when (< i 0) (go I5))
|
||||
I3 ; Invert one
|
||||
(X! m j)
|
||||
(set! j (- m))
|
||||
(set! m i)
|
||||
(set! i (X m))
|
||||
I4 ; End of cycle?
|
||||
(when (> i 0) (go I3))
|
||||
(set! i j)
|
||||
I5 ; Store final value
|
||||
(X! m (- i))
|
||||
I6 ; Loop on m
|
||||
(set! m (- m 1))
|
||||
(when (> m 0) (go I2))))
|
||||
|
||||
(check-equal? permutation #(dummy 3 2 6 5 4 1))
|
||||
|
||||
; Example 6 (The CommonLisp Hyper Spec examples of tagbody)
|
||||
|
||||
(define val 'foo)
|
||||
(tagged-begin
|
||||
(set! val 1)
|
||||
(go a)
|
||||
c (set! val (+ val 4))
|
||||
(go b)
|
||||
(set! val (+ val 32))
|
||||
a (set! val (+ val 2))
|
||||
(go c)
|
||||
(set! val (+ val 64))
|
||||
b (set! val (+ val 8)))
|
||||
(check-equal? val 15)
|
||||
|
||||
(define (f1 flag)
|
||||
(let ((n 1))
|
||||
(tagged-begin
|
||||
(set! n (f2 flag (lambda () (go out))))
|
||||
out
|
||||
(displayln n))))
|
||||
|
||||
(define (f2 flag escape)
|
||||
(if flag (escape) 2))
|
||||
|
||||
; (f1 #f) ; displays 2
|
||||
; (f1 #t) ; displays 1
|
||||
|
||||
; Example 7
|
||||
; Demonstrates lexical scoping of tagged-begins,
|
||||
; and that an inner tagged-begin can use an outer tag.
|
||||
|
||||
(check-equal?
|
||||
(tagged-begin
|
||||
a (tagged-begin
|
||||
(go b))
|
||||
b (return 'hello-world))
|
||||
'hello-world)
|
||||
|
||||
; Demonstrates that tags are lexically shadowed.
|
||||
(check-equal?
|
||||
(tagged-begin
|
||||
a (tagged-begin
|
||||
(go b)
|
||||
(return 'wrong)
|
||||
b (go c))
|
||||
b (return 'wrong)
|
||||
c (return 'correct))
|
||||
'correct)
|
||||
|
||||
)
|
||||
13
control/until.rkt
Normal file
13
control/until.rkt
Normal file
|
|
@ -0,0 +1,13 @@
|
|||
#lang racket
|
||||
(provide until)
|
||||
|
||||
|
||||
(require (for-syntax syntax/parse))
|
||||
|
||||
(define-syntax (until stx)
|
||||
(syntax-parse stx
|
||||
[(_until expr body ...)
|
||||
#'(let loop ()
|
||||
body ...
|
||||
(when (not expr)
|
||||
(loop)))]))
|
||||
19
control/while.rkt
Normal file
19
control/while.rkt
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
#lang racket
|
||||
(provide while)
|
||||
|
||||
; SYNTAX (while expr body ...)
|
||||
; 1. Evaluate expr
|
||||
; 2. If the result is true, then evaluate body ... and go to 1.
|
||||
; 3. Return (void)
|
||||
|
||||
(require (for-syntax syntax/parse))
|
||||
(define-syntax (while stx)
|
||||
(syntax-parse stx
|
||||
[(_while test-expr body ...)
|
||||
#'(let loop ()
|
||||
(when test
|
||||
body ...
|
||||
(loop)))]
|
||||
[_
|
||||
(raise-syntax-error
|
||||
#f "(while test-expr body ...) expected, got:" stx)]))
|
||||
Loading…
Reference in New Issue
Block a user