;;;
;;; VERSIONMAC:  Macros for the version control system
;;;
;;; ----------------------------------------------------------------------
;;;
;;; This file is part of ILOG Talk.
;;; Inquiries to ILOG S.A.
;;;              9 rue de Verdun, BP 85,
;;;              94253 Gentilly Cedex, France.
;;;
;;; Copyright (c) 1992-1996 by ILOG
;;; $Header: /nfs/talk/work/talk/contrib/src/RCS/iltverm.t,v 3.12 1996/01/13 12:03:54 v16admin Exp $
;;; ----------------------------------------------------------------------
;;;

(defun .compute-vcs-class-name (name)
  ;; convert an external vcs system name to the name of the class
  ;; which represents it.
  (symbol 'internal (catenate "<" name "-system>")))

(defun .compute-vcs-operation-name (name)
  ;; Convert an external vcs operation name to the name of the generic
  ;; function which represents it.
  (symbol 'internal (catenate name "-using-system")))

(defmacro define-version-control-system (name)
  ;; Defines a new version control system named NAME.
  ;; \\ Does it make any sense to have a hierarchy of systems?
  (let ((class-name (.compute-vcs-class-name name)))
    `(.defclass ,class-name (.<default-system>)
       ()
       metaclass: .<vcs-class>
       metaclass-keywords: (.name: ',name))))

(defmacro define-version-control-operation (name system args rest: body)
  ;; Define a method on the version control system operation named
  ;; NAME for the vcs system named SYSTEM, with arguments ARGS and
  ;; body BODY.
  (let ((real-name (.compute-vcs-operation-name name))
	(system-name (.compute-vcs-class-name system)))
    `(defmethod ,real-name ((system ,system-name) ,@args)
       system ; ignore system or not
       ,@body)))

(defmacro define-new-version-control-operation (name args rest: default-body)
  ;; Defines a new version control system operation named NAME, taking
  ;; arguments ARGS, and with a default implementation of DEFAULT-BODY.
  (let ((real-name (.compute-vcs-operation-name name)))
    `(progn
       (defun ,name ,args
	 (,real-name (current-version-control-system) ,@args))
       (defgeneric ,real-name (system ,@args)
	 class: .<vcs-generic-function>
	 methods: ((((system .<default-system>) ,@args)
		   (ignore system)
		   ,@default-body)))
       ',name)))

  
