mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-02 13:00:26 +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)))))))

11
test-suite/tests/syntax.test
View file

@ -1,6 +1,6 @@
;;;; syntax.test --- test suite for Guile's syntactic forms -*- scheme -*-
;;;;
;;;; Copyright (C) 2001,2003,2004, 2005, 2006, 2009 Free Software Foundation, Inc.
;;;; Copyright (C) 2001,2003,2004, 2005, 2006, 2009, 2010 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@ -75,6 +75,9 @@
(define exception:bad-cond-clause
(cons 'syntax-error "Bad cond clause"))
(define exception:too-many-args
(cons 'syntax-error "too many arguments"))
(with-test-prefix "expressions"
@ -832,7 +835,7 @@
#t))))
(pass-if-exception "too few args" exception:wrong-num-args
(pass-if-exception "too few args" exception:generic-syncase-error
(eval '(while) (interaction-environment)))
(with-test-prefix "empty body"
@ -872,7 +875,7 @@
(with-test-prefix "break"
(pass-if-exception "too many args" exception:wrong-num-args
(pass-if-exception "too many args" exception:too-many-args
(eval '(while #t
(break 1))
(interaction-environment)))
@ -945,7 +948,7 @@
(with-test-prefix "continue"
(pass-if-exception "too many args" exception:wrong-num-args
(pass-if-exception "too many args" exception:too-many-args
(eval '(while #t
(continue 1))
(interaction-environment)))