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

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

Browse source 
Conflicts:
	libguile/procprop.c
This commit is contained in:
Andy Wingo 2011-05-25 10:32:19 +02:00
commit a099c8d971
24 changed files with 469 additions and 282 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -3043,15 +3043,15 @@ module '(ice-9 q) '(make-q q-length))}."
#`(#:filename 'f . #,(parse #'args imp exp rex rep aut)))
((#:use-module (name name* ...) . args)
(and (and-map symbol? (syntax->datum #'(name name* ...))))
(parse #'args (cons #'((name name* ...)) imp) exp rex rep aut))
(parse #'args #`(#,@imp ((name name* ...))) exp rex rep aut))
((#:use-syntax (name name* ...) . args)
(and (and-map symbol? (syntax->datum #'(name name* ...))))
#`(#:transformer '(name name* ...)
. #,(parse #'args (cons #'((name name* ...)) imp) exp rex rep aut)))
. #,(parse #'args #`(#,@imp ((name name* ...))) exp rex rep aut)))
((#:use-module ((name name* ...) arg ...) . args)
(and (and-map symbol? (syntax->datum #'(name name* ...))))
(parse #'args
(cons #`((name name* ...) #,@(parse-iface #'(arg ...))) imp)
#`(#,@imp ((name name* ...) #,@(parse-iface #'(arg ...))))
exp rex rep aut))
((#:export (ex ...) . args)
(parse #'args imp #`(#,@exp ex ...) rex rep aut))

152
module/oop/goops.scm
View file

@ -1,6 +1,6 @@
;;; installed-scm-file
;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010 Free Software Foundation, Inc.
;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010, 2011 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
@ -245,31 +245,28 @@
(lambda (x)
(syntax-case x ()
((_ (k arg rest ...) out ...)
(keyword? (syntax->datum (syntax k)))
(case (syntax->datum (syntax k))
(keyword? (syntax->datum #'k))
(case (syntax->datum #'k)
((#:getter #:setter)
(syntax
(define-class-pre-definition (rest ...)
out ...
(if (or (not (defined? 'arg))
(not (is-a? arg <generic>)))
(toplevel-define!
'arg
(ensure-generic (if (defined? 'arg) arg #f) 'arg))))))
#'(define-class-pre-definition (rest ...)
out ...
(if (or (not (defined? 'arg))
(not (is-a? arg <generic>)))
(toplevel-define!
'arg
(ensure-generic (if (defined? 'arg) arg #f) 'arg)))))
((#:accessor)
(syntax
(define-class-pre-definition (rest ...)
out ...
(if (or (not (defined? 'arg))
(not (is-a? arg <accessor>)))
(toplevel-define!
'arg
(ensure-accessor (if (defined? 'arg) arg #f) 'arg))))))
#'(define-class-pre-definition (rest ...)
out ...
(if (or (not (defined? 'arg))
(not (is-a? arg <accessor>)))
(toplevel-define!
'arg
(ensure-accessor (if (defined? 'arg) arg #f) 'arg)))))
(else
(syntax
(define-class-pre-definition (rest ...) out ...)))))
#'(define-class-pre-definition (rest ...) out ...))))
((_ () out ...)
(syntax (begin out ...))))))
#'(begin out ...)))))
;; Some slot options require extra definitions to be made. In
;; particular, we want to make sure that the generic function objects
@ -279,17 +276,17 @@
(lambda (x)
(syntax-case x ()
((_ () out ...)
(syntax (begin out ...)))
#'(begin out ...))
((_ (slot rest ...) out ...)
(keyword? (syntax->datum (syntax slot)))
(syntax (begin out ...)))
(keyword? (syntax->datum #'slot))
#'(begin out ...))
((_ (slot rest ...) out ...)
(identifier? (syntax slot))
(syntax (define-class-pre-definitions (rest ...)
out ...)))
(identifier? #'slot)
#'(define-class-pre-definitions (rest ...)
out ...))
((_ ((slotname slotopt ...) rest ...) out ...)
(syntax (define-class-pre-definitions (rest ...)
out ... (define-class-pre-definition (slotopt ...))))))))
#'(define-class-pre-definitions (rest ...)
out ... (define-class-pre-definition (slotopt ...)))))))
(define-syntax define-class
(syntax-rules ()
@ -491,46 +488,46 @@
(let lp ((ls args) (formals '()) (specializers '()))
(syntax-case ls ()
(((f s) . rest)
(and (identifier? (syntax f)) (identifier? (syntax s)))
(lp (syntax rest)
(cons (syntax f) formals)
(cons (syntax s) specializers)))
(and (identifier? #'f) (identifier? #'s))
(lp #'rest
(cons #'f formals)
(cons #'s specializers)))
((f . rest)
(identifier? (syntax f))
(lp (syntax rest)
(cons (syntax f) formals)
(cons (syntax <top>) specializers)))
(identifier? #'f)
(lp #'rest
(cons #'f formals)
(cons #'<top> specializers)))
(()
(list (reverse formals)
(reverse (cons (syntax '()) specializers))))
(reverse (cons #''() specializers))))
(tail
(identifier? (syntax tail))
(list (append (reverse formals) (syntax tail))
(reverse (cons (syntax <top>) specializers)))))))
(identifier? #'tail)
(list (append (reverse formals) #'tail)
(reverse (cons #'<top> specializers)))))))
(define (find-free-id exp referent)
(syntax-case exp ()
((x . y)
(or (find-free-id (syntax x) referent)
(find-free-id (syntax y) referent)))
(or (find-free-id #'x referent)
(find-free-id #'y referent)))
(x
(identifier? (syntax x))
(let ((id (datum->syntax (syntax x) referent)))
(and (free-identifier=? (syntax x) id) id)))
(identifier? #'x)
(let ((id (datum->syntax #'x referent)))
(and (free-identifier=? #'x id) id)))
(_ #f)))
(define (compute-procedure formals body)
(syntax-case body ()
((body0 ...)
(with-syntax ((formals formals))
(syntax (lambda formals body0 ...))))))
#'(lambda formals body0 ...)))))
(define (->proper args)
(let lp ((ls args) (out '()))
(syntax-case ls ()
((x . xs) (lp (syntax xs) (cons (syntax x) out)))
((x . xs) (lp #'xs (cons #'x out)))
(() (reverse out))
(tail (reverse (cons (syntax tail) out))))))
(tail (reverse (cons #'tail out))))))
(define (compute-make-procedure formals body next-method)
(syntax-case body ()
@ -538,24 +535,22 @@
(with-syntax ((next-method next-method))
(syntax-case formals ()
((formal ...)
(syntax
(lambda (real-next-method)
(lambda (formal ...)
(let ((next-method (lambda args
(if (null? args)
(real-next-method formal ...)
(apply real-next-method args)))))
body ...)))))
#'(lambda (real-next-method)
(lambda (formal ...)
(let ((next-method (lambda args
(if (null? args)
(real-next-method formal ...)
(apply real-next-method args)))))
body ...))))
(formals
(with-syntax (((formal ...) (->proper (syntax formals))))
(syntax
(lambda (real-next-method)
(lambda formals
(let ((next-method (lambda args
(if (null? args)
(apply real-next-method formal ...)
(apply real-next-method args)))))
body ...)))))))))))
(with-syntax (((formal ...) (->proper #'formals)))
#'(lambda (real-next-method)
(lambda formals
(let ((next-method (lambda args
(if (null? args)
(apply real-next-method formal ...)
(apply real-next-method args)))))
body ...))))))))))
(define (compute-procedures formals body)
;; So, our use of this is broken, because it operates on the
@ -564,28 +559,27 @@
(let ((id (find-free-id body 'next-method)))
(if id
;; return a make-procedure
(values (syntax #f)
(values #'#f
(compute-make-procedure formals body id))
(values (compute-procedure formals body)
(syntax #f)))))
#'#f))))
(syntax-case x ()
((_ args) (syntax (method args (if #f #f))))
((_ args) #'(method args (if #f #f)))
((_ args body0 body1 ...)
(with-syntax (((formals (specializer ...)) (parse-args (syntax args))))
(with-syntax (((formals (specializer ...)) (parse-args #'args)))
(call-with-values
(lambda ()
(compute-procedures (syntax formals) (syntax (body0 body1 ...))))
(compute-procedures #'formals #'(body0 body1 ...)))
(lambda (procedure make-procedure)
(with-syntax ((procedure procedure)
(make-procedure make-procedure))
(syntax
(make <method>
#:specializers (cons* specializer ...)
#:formals 'formals
#:body '(body0 body1 ...)
#:make-procedure make-procedure
#:procedure procedure))))))))))
#'(make <method>
#:specializers (cons* specializer ...)
#:formals 'formals
#:body '(body0 body1 ...)
#:make-procedure make-procedure
#:procedure procedure)))))))))
;;;
;;; {add-method!}

78
module/rnrs/io/ports.scm
View file

@ -170,22 +170,44 @@
;;;
(define (with-i/o-filename-conditions filename thunk)
(catch 'system-error
thunk
(lambda args
(let ((errno (system-error-errno args)))
(let ((construct-condition
(cond ((= errno EACCES)
make-i/o-file-protection-error)
((= errno EEXIST)
make-i/o-file-already-exists-error)
((= errno ENOENT)
make-i/o-file-does-not-exist-error)
((= errno EROFS)
make-i/o-file-is-read-only-error)
(else
make-i/o-filename-error))))
(raise (construct-condition filename)))))))
(with-throw-handler 'system-error
thunk
(lambda args
(let ((errno (system-error-errno args)))
(let ((construct-condition
(cond ((= errno EACCES)
make-i/o-file-protection-error)
((= errno EEXIST)
make-i/o-file-already-exists-error)
((= errno ENOENT)
make-i/o-file-does-not-exist-error)
((= errno EROFS)
make-i/o-file-is-read-only-error)
(else
make-i/o-filename-error))))
(raise (construct-condition filename)))))))
(define (with-i/o-port-error port make-primary-condition thunk)
(with-throw-handler 'system-error
thunk
(lambda args
(let ((errno (system-error-errno args)))
(if (memv errno (list EIO EFBIG ENOSPC EPIPE))
(raise (condition (make-primary-condition)
(make-i/o-port-error port)))
(apply throw args))))))
(define-syntax with-textual-output-conditions
(syntax-rules ()
((_ port body0 body ...)
(with-i/o-port-error port make-i/o-write-error
(lambda () (with-i/o-encoding-error body0 body ...))))))
(define-syntax with-textual-input-conditions
(syntax-rules ()
((_ port body0 body ...)
(with-i/o-port-error port make-i/o-read-error
(lambda () (with-i/o-decoding-error body0 body ...))))))
;;;
@ -313,7 +335,10 @@ as a string, and a thunk to retrieve the characters associated with that port."
O_CREAT)
(if (enum-set-member? 'no-truncate file-options)
0
O_TRUNC)))
O_TRUNC)
(if (enum-set-member? 'no-fail file-options)
0
O_EXCL)))
(port (with-i/o-filename-conditions filename
(lambda () (open filename flags)))))
(cond (maybe-transcoder
@ -363,13 +388,13 @@ return the characters accumulated in that port."
(raise (make-i/o-encoding-error port chr)))))))
(define (put-char port char)
(with-i/o-encoding-error (write-char char port)))
(with-textual-output-conditions port (write-char char port)))
(define (put-datum port datum)
(with-i/o-encoding-error (write datum port)))
(with-textual-output-conditions port (write datum port)))
(define* (put-string port s #:optional start count)
(with-i/o-encoding-error
(with-textual-output-conditions port
(cond ((not (string? s))
(assertion-violation 'put-string "expected string" s))
((and start count)
@ -382,8 +407,7 @@ return the characters accumulated in that port."
;; Defined here to be able to make use of `with-i/o-encoding-error', but
;; not exported from here, but from `(rnrs io simple)'.
(define* (display object #:optional (port (current-output-port)))
(with-i/o-encoding-error
(guile:display object port)))
(with-textual-output-conditions port (guile:display object port)))
;;;
@ -406,16 +430,16 @@ return the characters accumulated in that port."
(raise (make-i/o-decoding-error port)))))))
(define (get-char port)
(with-i/o-decoding-error (read-char port)))
(with-textual-input-conditions port (read-char port)))
(define (get-datum port)
(with-i/o-decoding-error (read port)))
(with-textual-input-conditions port (read port)))
(define (get-line port)
(with-i/o-decoding-error (read-line port 'trim)))
(with-textual-input-conditions port (read-line port 'trim)))
(define (get-string-all port)
(with-i/o-decoding-error (read-delimited "" port 'concat)))
(with-textual-input-conditions port (read-delimited "" port 'concat)))
(define (get-string-n port count)
"Read up to @var{count} characters from @var{port}.
@ -429,7 +453,7 @@ the characters read."
(else (substring/shared s 0 rv)))))
(define (lookahead-char port)
(with-i/o-decoding-error (peek-char port)))
(with-textual-input-conditions port (peek-char port)))
;;;