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

* goops.scm (change-object-class): Quote empty list constants.

Browse source 
(method): Reverted previous change (enclosing body);
Quote empty list.
(initialize <method>): Pre-expand the method closure.
This commit is contained in:
Mikael Djurfeldt 2001-03-04 05:28:21 +00:00
parent 87e7741df7
commit cc6c7feea4
2 changed files with 17 additions and 7 deletions
Download patch file Download diff file Expand all files Collapse all files

7
oop/ChangeLog
View file

@ -1,3 +1,10 @@
2001-03-04 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
* goops.scm (change-object-class): Quote empty list constants.
(method): Reverted previous change (enclosing body);
Quote empty list.
(initialize <method>): Pre-expand the method closure.
2001-02-23 Keisuke Nishida <kxn30@po.cwru.edu> 2001-02-23 Keisuke Nishida <kxn30@po.cwru.edu>
* goops.scm (method): Enclosed BODY by `(let () ...)'. * goops.scm (method): Enclosed BODY by `(let () ...)'.

17
oop/goops.scm
View file

@ -1,6 +1,6 @@
;;; installed-scm-file ;;; installed-scm-file
;;;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc. ;;;; Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc.
;;;; ;;;;
;;;; This program is free software; you can redistribute it and/or modify ;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by ;;;; it under the terms of the GNU General Public License as published by
@ -468,7 +468,7 @@
(define method (define method
(letrec ((specializers (letrec ((specializers
(lambda (ls) (lambda (ls)
(cond ((null? ls) (list ls)) (cond ((null? ls) '('()))
((pair? ls) (cons (if (pair? (car ls)) ((pair? ls) (cons (if (pair? (car ls))
(cadar ls) (cadar ls)
'<top>) '<top>)
@ -487,9 +487,9 @@
`(make <method> `(make <method>
#:specializers (list* ,@(specializers args)) #:specializers (list* ,@(specializers args))
#:procedure (lambda ,(formals args) #:procedure (lambda ,(formals args)
,(if (null? body) ,@(if (null? body)
*unspecified* (list *unspecified*)
`(let () ,@body))))))))) body))))))))
;;; ;;;
;;; {add-method!} ;;; {add-method!}
@ -1318,7 +1318,10 @@
(next-method) (next-method)
(slot-set! method 'generic-function (get-keyword #:generic-function initargs #f)) (slot-set! method 'generic-function (get-keyword #:generic-function initargs #f))
(slot-set! method 'specializers (get-keyword #:specializers initargs '())) (slot-set! method 'specializers (get-keyword #:specializers initargs '()))
(slot-set! method 'procedure (get-keyword #:procedure initargs (lambda l '()))) (slot-set! method
'procedure
(%pre-expand-closure!
(get-keyword #:procedure initargs (lambda l '()))))
(slot-set! method 'code-table '())) (slot-set! method 'code-table '()))
(define-method initialize ((obj <foreign-object>) initargs)) (define-method initialize ((obj <foreign-object>) initargs))
@ -1328,7 +1331,7 @@
;;; ;;;
(define (change-object-class old-instance old-class new-class) (define (change-object-class old-instance old-class new-class)
(let ((new-instance (allocate-instance new-class ()))) (let ((new-instance (allocate-instance new-class '())))
;; Initalize the slot of the new instance ;; Initalize the slot of the new instance
(for-each (lambda (slot) (for-each (lambda (slot)
(if (and (slot-exists-using-class? old-class old-instance slot) (if (and (slot-exists-using-class? old-class old-instance slot)