/[guile]/guile/guile-core/oop/goops.scm
ViewVC logotype

Diff of /guile/guile-core/oop/goops.scm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.14 by mdj, Sun Oct 21 09:47:55 2001 UTC revision 1.15 by dirk, Mon Jul 8 20:40:32 2002 UTC
# Line 1  Line 1 
1  ;;; installed-scm-file  ;;; installed-scm-file
2    
3  ;;;;    Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc.  ;;;; Copyright (C) 1998,1999,2000,2001,2002 Free Software Foundation, Inc.
4  ;;;;  ;;;;
5  ;;;; This program is free software; you can redistribute it and/or modify  ;;;; This program is free software; you can redistribute it and/or modify
6  ;;;; 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
# Line 224  Line 224 
224             (name cadr)             (name cadr)
225             (slots cdddr))             (slots cdddr))
226            
227      (procedure->macro      (procedure->memoizing-macro
228        (lambda (exp env)        (lambda (exp env)
229          (cond ((not (top-level-env? env))          (cond ((not (top-level-env? env))
230                 (goops-error "define-class: Only allowed at top level"))                 (goops-error "define-class: Only allowed at top level"))
# Line 361  Line 361 
361  ;;;  ;;;
362    
363  (define define-generic  (define define-generic
364    (procedure->macro    (procedure->memoizing-macro
365      (lambda (exp env)      (lambda (exp env)
366        (let ((name (cadr exp)))        (let ((name (cadr exp)))
367          (cond ((not (symbol? name))          (cond ((not (symbol? name))
368                 (goops-error "bad generic function name: ~S" name))                 (goops-error "bad generic function name: ~S" name))
369                ((defined? name env)                ((and (top-level-env? env)
370                        (defined? name env))
371                 `(define ,name                 `(define ,name
372                    (if (is-a? ,name <generic>)                    (if (is-a? ,name <generic>)
373                        (make <generic> #:name ',name)                        (make <generic> #:name ',name)
# Line 391  Line 392 
392            (else (make <generic> #:name name)))))            (else (make <generic> #:name name)))))
393    
394  (define define-accessor  (define define-accessor
395    (procedure->macro    (procedure->memoizing-macro
396      (lambda (exp env)      (lambda (exp env)
397        (let ((name (cadr exp)))        (let ((name (cadr exp)))
398          (cond ((not (symbol? name))          (cond ((not (symbol? name))
399                 (goops-error "bad accessor name: ~S" name))                 (goops-error "bad accessor name: ~S" name))
400                ((defined? name env)                ((and (top-level-env? env)
401                        (defined? name env))
402                 `(define ,name                 `(define ,name
403                    (if (and (is-a? ,name <generic-with-setter>)                    (if (and (is-a? ,name <generic-with-setter>)
404                             (is-a? (setter ,name) <generic>))                             (is-a? (setter ,name) <generic>))

Legend:
Removed from v.1.14  
changed lines
  Added in v.1.15

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26