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

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

Browse source 
This was a pretty big merge involving a fair amount of porting,
especially to peval and its tests.  I did not update psyntax-pp.scm,
that comes in the next commit.

Conflicts:
	module/ice-9/boot-9.scm
	module/ice-9/psyntax-pp.scm
	module/language/ecmascript/compile-tree-il.scm
	module/language/tree-il.scm
	module/language/tree-il/analyze.scm
	module/language/tree-il/inline.scm
	test-suite/tests/tree-il.test
This commit is contained in:
Andy Wingo 2011-09-29 18:02:28 +02:00
commit ca12824581
60 changed files with 3173 additions and 957 deletions
Download patch file Download diff file Expand all files Collapse all files

67
module/oop/goops.scm
View file

@ -347,21 +347,18 @@
#'(define-class-pre-definitions (rest ...)
out ... (define-class-pre-definition (slotopt ...)))))))
(define-syntax define-class
(syntax-rules ()
((_ name supers slot ...)
(begin
(define-class-pre-definitions (slot ...))
(if (and (defined? 'name)
(is-a? name <class>)
(memq <object> (class-precedence-list name)))
(class-redefinition name
(class supers slot ... #:name 'name))
(toplevel-define! 'name (class supers slot ... #:name 'name)))))))
(define-syntax-rule (define-class name supers slot ...)
(begin
(define-class-pre-definitions (slot ...))
(if (and (defined? 'name)
(is-a? name <class>)
(memq <object> (class-precedence-list name)))
(class-redefinition name
(class supers slot ... #:name 'name))
(toplevel-define! 'name (class supers slot ... #:name 'name)))))
(define-syntax standard-define-class
(syntax-rules ()
((_ arg ...) (define-class arg ...))))
(define-syntax-rule (standard-define-class arg ...)
(define-class arg ...))
;;;
;;; {Generic functions and accessors}
@ -428,13 +425,15 @@
(for-each (lambda (gf)
(slot-set! gf 'extended-by
(cons eg (slot-ref gf 'extended-by))))
gfs))
gfs)
(invalidate-method-cache! eg))
(define (not-extended-by! gfs eg)
(for-each (lambda (gf)
(slot-set! gf 'extended-by
(delq! eg (slot-ref gf 'extended-by))))
gfs))
gfs)
(invalidate-method-cache! eg))
(define* (ensure-generic old-definition #:optional name)
(cond ((is-a? old-definition <generic>) old-definition)
@ -449,13 +448,11 @@
(else (make <generic> #:name name))))
;; same semantics as <generic>
(define-syntax define-accessor
(syntax-rules ()
((_ name)
(define name
(cond ((not (defined? 'name)) (ensure-accessor #f 'name))
((is-a? name <accessor>) (make <accessor> #:name 'name))
(else (ensure-accessor name 'name)))))))
(define-syntax-rule (define-accessor name)
(define name
(cond ((not (defined? 'name)) (ensure-accessor #f 'name))
((is-a? name <accessor>) (make <accessor> #:name 'name))
(else (ensure-accessor name 'name)))))
(define (make-setter-name name)
(string->symbol (string-append "setter:" (symbol->string name))))
@ -505,6 +502,7 @@
(slot-set! method 'generic-function gws))
methods)
(slot-set! gws 'methods methods)
(invalidate-method-cache! gws)
gws))
;;;
@ -669,15 +667,25 @@
methods)
(loop (cdr l)))))))
(define (method-n-specializers m)
(length* (slot-ref m 'specializers)))
(define (calculate-n-specialized gf)
(fold (lambda (m n) (max n (method-n-specializers m)))
0
(generic-function-methods gf)))
(define (invalidate-method-cache! gf)
(%invalidate-method-cache! gf)
(slot-set! gf 'n-specialized (calculate-n-specialized gf))
(for-each (lambda (gf) (invalidate-method-cache! gf))
(slot-ref gf 'extended-by)))
(define internal-add-method!
(method ((gf <generic>) (m <method>))
(slot-set! m 'generic-function gf)
(slot-set! gf 'methods (compute-new-list-of-methods gf m))
(let ((specializers (slot-ref m 'specializers)))
(slot-set! gf 'n-specialized
(max (length* specializers)
(slot-ref gf 'n-specialized))))
(%invalidate-method-cache! gf)
(invalidate-method-cache! gf)
(add-method-in-classes! m)
*unspecified*))
@ -917,6 +925,7 @@
(slot-set! val2
'extended-by
(cons gf (delq! gf (slot-ref val2 'extended-by))))
(invalidate-method-cache! gf)
var)))
(module-define! duplicate-handlers 'merge-generics merge-generics)
@ -1100,7 +1109,7 @@
;; remove the method from its GF
(slot-set! gf 'methods
(delq1! m (slot-ref gf 'methods)))
(%invalidate-method-cache! gf)
(invalidate-method-cache! gf)
;; remove the method from its specializers
(remove-method-in-classes! m))))
(class-direct-methods c)))

8
module/oop/goops/simple.scm
View file

@ -1,6 +1,6 @@
;;; installed-scm-file
;;;; Copyright (C) 2005, 2006, 2010 Free Software Foundation, Inc.
;;;; Copyright (C) 2005, 2006, 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
@ -23,10 +23,8 @@
:export (define-class)
:no-backtrace)
(define-syntax define-class
(syntax-rules ()
((_ arg ...)
(define-class-with-accessors-keywords arg ...))))
(define-syntax-rule (define-class arg ...)
(define-class-with-accessors-keywords arg ...))
(module-use! (module-public-interface (current-module))
(resolve-interface '(oop goops)))

8
module/oop/goops/stklos.scm
View file

@ -1,4 +1,4 @@
;;;; Copyright (C) 1999,2002, 2006, 2010 Free Software Foundation, Inc.
;;;; Copyright (C) 1999,2002, 2006, 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
@ -47,10 +47,8 @@
;;; Enable keyword support (*fixme*---currently this has global effect)
(read-set! keywords 'prefix)
(define-syntax define-class
(syntax-rules ()
((_ name supers (slot ...) rest ...)
(standard-define-class name supers slot ... rest ...))))
(define-syntax-rule (define-class name supers (slot ...) rest ...)
(standard-define-class name supers slot ... rest ...))
(define (toplevel-define! name val)
(module-define! (current-module) name val))