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 |
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")) |
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) |
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>)) |