mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-06 23:50:18 +02:00
Code Activity

while in terms of syntax-case

Browse source 
* module/ice-9/boot-9.scm (while): Reimplement in terms of syntax-case.
  Prompt inlining is coming later.

* test-suite/tests/syntax.test ("while"): Update the expected syntax
  errors.
This commit is contained in:
Andy Wingo 2010-06-11 16:57:50 +02:00
parent 322a36ce9f
commit 10e69149f6
2 changed files with 46 additions and 25 deletions
Download patch file Download diff file Expand all files Collapse all files

60
module/ice-9/boot-9.scm
View file

@ -2842,28 +2842,46 @@ module '(ice-9 q) '(make-q q-length))}."
;;; with `continue' and `break'.
;;;
;; The inner `do' loop avoids re-establishing a catch every iteration,
;; that's only necessary if continue is actually used. A new key is
;; generated every time, so break and continue apply to their originating
;; `while' even when recursing.
;; The inliner will remove the prompts at compile-time if it finds that
;; `continue' or `break' are not used.
;;
;; FIXME: This macro is unintentionally unhygienic with respect to let,
;; make-symbol, do, throw, catch, lambda, and not.
;;
(define-macro (while cond . body)
(let ((keyvar (make-symbol "while-keyvar")))
`(let ((,keyvar (make-symbol "while-key")))
(do ()
((catch ,keyvar
(lambda ()
(let ((break (lambda () (throw ,keyvar #t)))
(continue (lambda () (throw ,keyvar #f))))
(do ()
((not ,cond))
,@body)
#t))
(lambda (key arg)
arg)))))))
(define-syntax while
(lambda (x)
(syntax-case x ()
((while cond body ...)
#`(let ((break-tag (make-prompt-tag "break"))
(continue-tag (make-prompt-tag "continue")))
(call-with-prompt
break-tag
(lambda ()
(define-syntax #,(datum->syntax #'while 'break)
(lambda (x)
(syntax-case x ()
((_)
#'(abort-to-prompt break-tag))
((_ . args)
(syntax-violation 'break "too many arguments" x))
(_
#'(lambda ()
(abort-to-prompt break-tag))))))
(let lp ()
(call-with-prompt
continue-tag
(lambda ()
(define-syntax #,(datum->syntax #'while 'continue)
(lambda (x)
(syntax-case x ()
((_)
#'(abort-to-prompt continue-tag))
((_ . args)
(syntax-violation 'continue "too many arguments" x))
(_
#'(lambda args
(apply abort-to-prompt continue-tag args))))))
(do () ((not cond)) body ...))
(lambda (k) (lp)))))
(lambda (k)
#t)))))))