atype.el

   1 ;;; atype.el --- atype functions
   2
   3 ;; Copyright (C) 1994,1995,1996,1997 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; Version: $Id: atype.el,v 6.6 1997/03/10 14:11:23 morioka Exp $
   7 ;; Keywords: atype
   8
   9 ;; This file is part of APEL (A Portable Emacs Library).
  10
  11 ;; This program is free software; you can redistribute it and/or
  12 ;; modify it under the terms of the GNU General Public License as
  13 ;; published by the Free Software Foundation; either version 2, or (at
  14 ;; your option) any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful, but
  17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, USA.
  25
  26 ;;; Code:
  27
  28 (require 'emu)                          ; for backward compatibility.
  29 (require 'poe)                          ; delete.
  30 (require 'alist)
  31
  32
  33 ;;; @ field unifier
  34 ;;;
  35
  36 (defun field-unifier-for-default (a b)
  37   (let ((ret
  38          (cond ((equal a b)    a)
  39                ((null (cdr b)) a)
  40                ((null (cdr a)) b)
  41                )))
  42     (if ret
  43         (list nil ret nil)
  44       )))
  45
  46 (defun field-unify (a b)
  47   (let ((f
  48          (let ((type (car a)))
  49            (and (symbolp type)
  50                 (intern (concat "field-unifier-for-" (symbol-name type)))
  51                 ))))
  52     (or (fboundp f)
  53         (setq f (function field-unifier-for-default))
  54         )
  55     (funcall f a b)
  56     ))
  57
  58
  59 ;;; @ type unifier
  60 ;;;
  61
  62 (defun assoc-unify (class instance)
  63   (catch 'tag
  64     (let ((cla (copy-alist class))
  65           (ins (copy-alist instance))
  66           (r class)
  67           cell aret ret prev rest)
  68       (while r
  69         (setq cell (car r))
  70         (setq aret (assoc (car cell) ins))
  71         (if aret
  72             (if (setq ret (field-unify cell aret))
  73                 (progn
  74                   (if (car ret)
  75                       (setq prev (put-alist (car (car ret))
  76                                             (cdr (car ret))
  77                                             prev))
  78                     )
  79                   (if (nth 2 ret)
  80                       (setq rest (put-alist (car (nth 2 ret))
  81                                             (cdr (nth 2 ret))
  82                                             rest))
  83                     )
  84                   (setq cla (put-alist (car cell)(cdr (nth 1 ret)) cla))
  85                   (setq ins (del-alist (car cell) ins))
  86                   )
  87               (throw 'tag nil)
  88               ))
  89         (setq r (cdr r))
  90         )
  91       (setq r (copy-alist ins))
  92       (while r
  93         (setq cell (car r))
  94         (setq aret (assoc (car cell) cla))
  95         (if aret
  96             (if (setq ret (field-unify cell aret))
  97                 (progn
  98                   (if (car ret)
  99                       (setq prev (put-alist (car (car ret))
 100                                             (cdr (car ret))
 101                                             prev))
 102                     )
 103                   (if (nth 2 ret)
 104                       (setq rest (put-alist (car (nth 2 ret))
 105                                             (cdr (nth 2 ret))
 106                                             rest))
 107                     )
 108                   (setq cla (del-alist (car cell) cla))
 109                   (setq ins (put-alist (car cell)(cdr (nth 1 ret)) ins))
 110                   )
 111               (throw 'tag nil)
 112               ))
 113         (setq r (cdr r))
 114         )
 115       (list prev (append cla ins) rest)
 116       )))
 117
 118 (defun get-unified-alist (db al)
 119   (let ((r db) ret)
 120     (catch 'tag
 121       (while r
 122         (if (setq ret (nth 1 (assoc-unify (car r) al)))
 123             (throw 'tag ret)
 124           )
 125         (setq r (cdr r))
 126         ))))
 127
 128
 129 ;;; @ utilities
 130 ;;;
 131
 132 (defun delete-atype (atl al)
 133   (let* ((r atl) ret oal)
 134     (setq oal
 135           (catch 'tag
 136             (while r
 137               (if (setq ret (nth 1 (assoc-unify (car r) al)))
 138                   (throw 'tag (car r))
 139                 )
 140               (setq r (cdr r))
 141               )))
 142     (delete oal atl)
 143     ))
 144
 145 (defun remove-atype (sym al)
 146   (and (boundp sym)
 147        (set sym (delete-atype (eval sym) al))
 148        ))
 149
 150 (defun replace-atype (atl old-al new-al)
 151   (let* ((r atl) ret oal)
 152     (if (catch 'tag
 153           (while r
 154             (if (setq ret (nth 1 (assoc-unify (car r) old-al)))
 155                 (throw 'tag (rplaca r new-al))
 156               )
 157             (setq r (cdr r))
 158             ))
 159         atl)))
 160
 161 (defun set-atype (sym al &rest options)
 162   (if (null (boundp sym))
 163       (set sym al)
 164     (let* ((replacement (memq 'replacement options))
 165            (ignore-fields (car (cdr (memq 'ignore options))))
 166            (remove (or (car (cdr (memq 'remove options)))
 167                        (let ((ral (copy-alist al)))
 168                          (mapcar (function
 169                                   (lambda (type)
 170                                     (setq ral (del-alist type ral))
 171                                     ))
 172                                  ignore-fields)
 173                          ral)))
 174            )
 175       (set sym
 176            (or (if replacement
 177                    (replace-atype (eval sym) remove al)
 178                  )
 179                (cons al
 180                      (delete-atype (eval sym) remove)
 181                      )
 182                )))))
 183
 184
 185 ;;; @ end
 186 ;;;
 187
 188 (require 'product)
 189 (product-provide (provide 'atype) (require 'apel-ver))
 190
 191 ;;; atype.el ends here