Commit bb3df9c6 authored by Erick Gallesio's avatar Erick Gallesio

Added and exported the method-specializers-equal? method

parent 12459ecf
......@@ -2114,7 +2114,7 @@ fi
# Define the identity of the package.
PACKAGE=stklos
VERSION=0.97
VERSION=0.98dev
cat >>confdefs.h <<_ACEOF
......
......@@ -2,12 +2,12 @@ dnl configure.in for STklos
dnl
dnl Author: Erick Gallesio [eg@unice.fr]
dnl Creation date: 28-Dec-1999 21:19 (eg)
dnl Last file update: 14-Dec-2007 15:47 (eg)
dnl Last file update: 20-Dec-2007 23:40 (eg)
AC_INIT(src/stklos.c)
AC_PREREQ(2.52)
AM_INIT_AUTOMAKE(stklos, 0.97)
AM_INIT_AUTOMAKE(stklos, 0.98dev)
AM_CONFIG_HEADER(src/stklosconf.h)
AC_PROG_MAKE_SET
......
;;;;
;;;; object.stk -- -- A variation of the Gregor Kickzales Tiny CLOS for STklos
;;;;
;;;; Copyright 1993-2007 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; Copyright 1993-2008 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 20-Feb-1994 21:09
;;;; Last file update: 8-Nov-2007 23:16 (eg)
;;;; Last file update: 11-Jan-2008 14:50 (eg)
#|
......@@ -56,6 +56,7 @@
apply-generic apply-method apply-methods compute-applicable-methods
method-more-specific? sort-applicable-methods
method-procedure method-specializers method-generic-function
method-specializers-equal?
class-subclasses class-methods class-name class-direct-supers
class-direct-subclasses class-precedence-list class-direct-methods
class-direct-slots class-slots
......@@ -406,30 +407,19 @@
;=============================================================================
; ==== Define-generic
(define-macro (define-generic gf)
`(define ,gf (ensure-generic-function ',gf)))
(define-macro (define-generic gf :optional (meta <generic>))
`(define ,gf (ensure-generic-function ',gf ,meta)))
;==== Ensure-generic-function
(define (ensure-generic-function name)
(define (ensure-generic-function name :optional (metaclass <generic>))
(let ((old (symbol-value* name (current-module) #f)))
(if (generic? old)
old
(%symbol-define name
(make <generic> :name name
(make metaclass :name name
:default (and (procedure? old) old))
(current-module)))))
;//(define (ensure-generic-function name)
;// (let ((old (symbol-value name (current-module) #f)))
;// (if (generic? old)
;// old
;// (eval `(begin
;// (define ,name ,(make <generic>
;// :name name
;// :default (and (procedure? old) old)))
;// ,name)))))
;//
;=============================================================================
;
; D e f i n e - m e t h o d
......@@ -437,6 +427,14 @@
;=============================================================================
;==== Add-method!
(define (%method-specializers-equal? gf m1 m2)
(equal? (method-specializers m1)
(method-specializers m2)))
(define method-specializers-equal? ; will be redefined later as a method.
%method-specializers-equal?)
(define (add-method-in-classes! m)
;; Add method in all the classes which appears in its specializers list
(for-each* (lambda (x)
......@@ -453,12 +451,11 @@
(method-specializers m)))
(define (compute-new-list-of-methods gf new)
(let ((new-spec (method-specializers new))
(methods (generic-function-methods gf)))
(let ((methods (generic-function-methods gf)))
(let Loop ((l methods))
(if (null? l)
(cons new methods)
(if (equal? (method-specializers (car l)) new-spec)
(if (method-specializers-equal? gf (car l) new)
(begin
;; This spec. list already exists. Remove old method from dependents
(remove-method-in-classes! (car l))
......@@ -786,7 +783,7 @@
(define (compute-slot-accessors class slots)
;; accessors are made her in-line using a light version of ensure-method
;; accessors are made here in-line using a light version of ensure-method
;; in particular, the class of accessors is <accessor-method> and there
;; is no next method defined for them, since they are terminal.
......@@ -1091,16 +1088,13 @@
(no-applicable-method gf args))))
;// ;=============================================================================
;// ;
;// ; <Composite-metaclass>
;// ;=============================================================================
; ======================================================================
; Functions redefined as methods ...
; ======================================================================
(define-method method-specializers-equal? ((gf <generic>) m1 m2)
(%method-specializers-equal? gf m1 m2))
;//
;// (export <Composite-metaclass> <Active-metaclass>)
;//
;=============================================================================
;
; T o o l s
......
;;;;
;;;; repl.stk -- STklos REPL
;;;;
;;;; Copyright 2000-2007 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; Copyright 2000-2008 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 4-Jun-2000 15:07 (eg)
;;;; Last file update: 4-Jul-2007 15:11 (eg)
;;;; Last file update: 1-Jan-2008 14:54 (eg)
;;;;
;; This file defines the REPL module. This module does not export anything
......@@ -199,7 +199,7 @@ doc>
(%initialize-signals)
(when interactive?
(let ((line1 (format "STklos version ~A\n" (version)))
(line2 "Copyright (C) 1999-2007 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>\n")
(line2 "Copyright (C) 1999-2008 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>\n")
(line3 (format "[~a/~a]\n" (machine-type) (%thread-system))))
(display (do-color 'bold 'black "* " 'bold 'blue line1))
(display (do-color 'bold 'black " * " 'bold 'blue line2))
......
This diff is collapsed.
This source diff could not be displayed because it is too large. You can view the blob instead.
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment