mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-19 02:00:26 +02:00
Code Activity

Merge remote-tracking branch 'local-2.0/stable-2.0'

Browse source 
Conflicts:
	configure.ac
	libguile/finalizers.c
	libguile/finalizers.h
	libguile/gc.c
	libguile/gc.h
	libguile/inline.c
	libguile/inline.h
	libguile/ports.c
	libguile/smob.c
	libguile/smob.h
	module/ice-9/deprecated.scm
	module/ice-9/r4rs.scm
This commit is contained in:
Andy Wingo 2012-03-08 13:22:09 +01:00
commit bc61280992
11 changed files with 89 additions and 224 deletions
Download patch file Download diff file Expand all files Collapse all files

137
module/ice-9/psyntax-pp.scm
View file

@ -2682,83 +2682,6 @@
"source expression failed to match any pattern"
tmp-1)))))))
(define do
(make-syntax-transformer
'do
'macro
(lambda (orig-x)
(let ((tmp-1 orig-x))
(let ((tmp ($sc-dispatch
tmp-1
'(_ #(each (any any . any)) (any . each-any) . each-any))))
(if tmp
(apply (lambda (var init step e0 e1 c)
(let ((tmp-1 (map (lambda (v s)
(let ((tmp-1 s))
(let ((tmp ($sc-dispatch tmp-1 '())))
(if tmp
(apply (lambda () v) tmp)
(let ((tmp ($sc-dispatch tmp-1 '(any))))
(if tmp
(apply (lambda (e) e) tmp)
(syntax-violation 'do "bad step expression" orig-x s)))))))
var
step)))
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp
(apply (lambda (step)
(let ((tmp e1))
(let ((tmp-1 ($sc-dispatch tmp '())))
(if tmp-1
(apply (lambda ()
(list '#(syntax-object let ((top)) (hygiene guile))
'#(syntax-object doloop ((top)) (hygiene guile))
(map list var init)
(list '#(syntax-object if ((top)) (hygiene guile))
(list '#(syntax-object not ((top)) (hygiene guile)) e0)
(cons '#(syntax-object begin ((top)) (hygiene guile))
(append
c
(list (cons '#(syntax-object
doloop
((top))
(hygiene guile))
step)))))))
tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(any . each-any))))
(if tmp-1
(apply (lambda (e1 e2)
(list '#(syntax-object let ((top)) (hygiene guile))
'#(syntax-object doloop ((top)) (hygiene guile))
(map list var init)
(list '#(syntax-object if ((top)) (hygiene guile))
e0
(cons '#(syntax-object begin ((top)) (hygiene guile))
(cons e1 e2))
(cons '#(syntax-object begin ((top)) (hygiene guile))
(append
c
(list (cons '#(syntax-object
doloop
((top))
(hygiene guile))
step)))))))
tmp-1)
(syntax-violation
#f
"source expression failed to match any pattern"
tmp)))))))
tmp)
(syntax-violation
#f
"source expression failed to match any pattern"
tmp-1)))))
tmp)
(syntax-violation
#f
"source expression failed to match any pattern"
tmp-1)))))))
(define quasiquote
(make-syntax-transformer
'quasiquote
@ -3163,66 +3086,6 @@
"expression not valid outside of quasiquote"
x))))
(define case
(make-syntax-transformer
'case
'macro
(lambda (x)
(let ((tmp-1 x))
(let ((tmp ($sc-dispatch tmp-1 '(_ any any . each-any))))
(if tmp
(apply (lambda (e m1 m2)
(let ((tmp (let f ((clause m1) (clauses m2))
(if (null? clauses)
(let ((tmp-1 clause))
(let ((tmp ($sc-dispatch
tmp-1
'(#(free-id #(syntax-object else ((top)) (hygiene guile)))
any
.
each-any))))
(if tmp
(apply (lambda (e1 e2)
(cons '#(syntax-object begin ((top)) (hygiene guile)) (cons e1 e2)))
tmp)
(let ((tmp ($sc-dispatch tmp-1 '(each-any any . each-any))))
(if tmp
(apply (lambda (k e1 e2)
(list '#(syntax-object if ((top)) (hygiene guile))
(list '#(syntax-object memv ((top)) (hygiene guile))
'#(syntax-object t ((top)) (hygiene guile))
(list '#(syntax-object quote ((top)) (hygiene guile))
k))
(cons '#(syntax-object begin ((top)) (hygiene guile))
(cons e1 e2))))
tmp)
(syntax-violation 'case "bad clause" x clause))))))
(let ((tmp (f (car clauses) (cdr clauses))))
(let ((rest tmp))
(let ((tmp clause))
(let ((tmp ($sc-dispatch tmp '(each-any any . each-any))))
(if tmp
(apply (lambda (k e1 e2)
(list '#(syntax-object if ((top)) (hygiene guile))
(list '#(syntax-object memv ((top)) (hygiene guile))
'#(syntax-object t ((top)) (hygiene guile))
(list '#(syntax-object quote ((top)) (hygiene guile))
k))
(cons '#(syntax-object begin ((top)) (hygiene guile))
(cons e1 e2))
rest))
tmp)
(syntax-violation 'case "bad clause" x clause))))))))))
(let ((body tmp))
(list '#(syntax-object let ((top)) (hygiene guile))
(list (list '#(syntax-object t ((top)) (hygiene guile)) e))
body))))
tmp)
(syntax-violation
#f
"source expression failed to match any pattern"
tmp-1)))))))
(define make-variable-transformer
(lambda (proc)
(if (procedure? proc)

22
module/ice-9/psyntax.scm
View file

@ -608,22 +608,15 @@
;; syntax object wraps
;; <wrap> ::= ((<mark> ...) . (<subst> ...))
;; <subst> ::= <shift> | <subs>
;; <subs> ::= #(<old name> <label> (<mark> ...))
;; <shift> ::= positive fixnum
;; <wrap> ::= ((<mark> ...) . (<subst> ...))
;; <subst> ::= shift | <subs>
;; <subs> ::= #(ribcage #(<sym> ...) #(<mark> ...) #(<label> ...))
;; | #(ribcage (<sym> ...) (<mark> ...) (<label> ...))
(define-syntax make-wrap (identifier-syntax cons))
(define-syntax wrap-marks (identifier-syntax car))
(define-syntax wrap-subst (identifier-syntax cdr))
(define-syntax subst-rename? (identifier-syntax vector?))
(define-syntax-rule (rename-old x) (vector-ref x 0))
(define-syntax-rule (rename-new x) (vector-ref x 1))
(define-syntax-rule (rename-marks x) (vector-ref x 2))
(define-syntax-rule (make-rename old new marks)
(vector old new marks))
;; labels must be comparable with "eq?", have read-write invariance,
;; and distinct from symbols.
(define (gen-label)
@ -2903,6 +2896,9 @@
(binding (car bindings)))
#'(let (binding) body))))))))
;; This definition of 'do' is never used, as it is immediately
;; replaced by the definition in boot-9.scm.
#;
(define-syntax do
(lambda (orig-x)
(syntax-case orig-x ()
@ -3076,6 +3072,10 @@
"expression not valid outside of quasiquote"
x)))
;; This definition of 'case' is never used, as it is immediately
;; replaced by the definition in boot-9.scm. This version lacks
;; R7RS-mandated support for '=>'.
#;
(define-syntax case
(lambda (x)
(syntax-case x ()