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., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Code:
  27
  28 (require 'emu)
  29 (require 'alist)
  30
  31
  32 ;;; @ field unifier
  33 ;;;
  34
  35 (defun field-unifier-for-default (a b)
  36   (let ((ret
  37          (cond ((equal a b)    a)
  38                ((null (cdr b)) a)
  39                ((null (cdr a)) b)
  40                )))
  41     (if ret
  42         (list nil ret nil)
  43       )))
  44
  45 (defun field-unify (a b)
  46   (let ((f
  47          (let ((type (car a)))
  48            (and (symbolp type)
  49                 (intern (concat "field-unifier-for-" (symbol-name type)))
  50                 ))))
  51     (or (fboundp f)
  52         (setq f (function field-unifier-for-default))
  53         )
  54     (funcall f a b)
  55     ))
  56
  57
  58 ;;; @ type unifier
  59 ;;;
  60
  61 (defun assoc-unify (class instance)
  62   (catch 'tag
  63     (let ((cla (copy-alist class))
  64           (ins (copy-alist instance))
  65           (r class)
  66           cell aret ret prev rest)
  67       (while r
  68         (setq cell (car r))
  69         (setq aret (assoc (car cell) ins))
  70         (if aret
  71             (if (setq ret (field-unify cell aret))
  72                 (progn
  73                   (if (car ret)
  74                       (setq prev (put-alist (car (car ret))
  75                                             (cdr (car ret))
  76                                             prev))
  77                     )
  78                   (if (nth 2 ret)
  79                       (setq rest (put-alist (car (nth 2 ret))
  80                                             (cdr (nth 2 ret))
  81                                             rest))
  82                     )
  83                   (setq cla (put-alist (car cell)(cdr (nth 1 ret)) cla))
  84                   (setq ins (del-alist (car cell) ins))
  85                   )
  86               (throw 'tag nil)
  87               ))
  88         (setq r (cdr r))
  89         )
  90       (setq r (copy-alist ins))
  91       (while r
  92         (setq cell (car r))
  93         (setq aret (assoc (car cell) cla))
  94         (if aret
  95             (if (setq ret (field-unify cell aret))
  96                 (progn
  97                   (if (car ret)
  98                       (setq prev (put-alist (car (car ret))
  99                                             (cdr (car ret))
 100                                             prev))
 101                     )
 102                   (if (nth 2 ret)
 103                       (setq rest (put-alist (car (nth 2 ret))
 104                                             (cdr (nth 2 ret))
 105                                             rest))
 106                     )
 107                   (setq cla (del-alist (car cell) cla))
 108                   (setq ins (put-alist (car cell)(cdr (nth 1 ret)) ins))
 109                   )
 110               (throw 'tag nil)
 111               ))
 112         (setq r (cdr r))
 113         )
 114       (list prev (append cla ins) rest)
 115       )))
 116
 117 (defun get-unified-alist (db al)
 118   (let ((r db) ret)
 119     (catch 'tag
 120       (while r
 121         (if (setq ret (nth 1 (assoc-unify (car r) al)))
 122             (throw 'tag ret)
 123           )
 124         (setq r (cdr r))
 125         ))))
 126
 127
 128 ;;; @ utilities
 129 ;;;
 130
 131 (defun delete-atype (atl al)
 132   (let* ((r atl) ret oal)
 133     (setq oal
 134           (catch 'tag
 135             (while r
 136               (if (setq ret (nth 1 (assoc-unify (car r) al)))
 137                   (throw 'tag (car r))
 138                 )
 139               (setq r (cdr r))
 140               )))
 141     (delete oal atl)
 142     ))
 143
 144 (defun remove-atype (sym al)
 145   (and (boundp sym)
 146        (set sym (delete-atype (eval sym) al))
 147        ))
 148
 149 (defun replace-atype (atl old-al new-al)
 150   (let* ((r atl) ret oal)
 151     (if (catch 'tag
 152           (while r
 153             (if (setq ret (nth 1 (assoc-unify (car r) old-al)))
 154                 (throw 'tag (rplaca r new-al))
 155               )
 156             (setq r (cdr r))
 157             ))
 158         atl)))
 159
 160 (defun set-atype (sym al &rest options)
 161   (if (null (boundp sym))
 162       (set sym al)
 163     (let* ((replacement (memq 'replacement options))
 164            (ignore-fields (car (cdr (memq 'ignore options))))
 165            (remove (or (car (cdr (memq 'remove options)))
 166                        (let ((ral (copy-alist al)))
 167                          (mapcar (function
 168                                   (lambda (type)
 169                                     (setq ral (del-alist type ral))
 170                                     ))
 171                                  ignore-fields)
 172                          ral)))
 173            )
 174       (set sym
 175            (or (if replacement
 176                    (replace-atype (eval sym) remove al)
 177                  )
 178                (cons al
 179                      (delete-atype (eval sym) remove)
 180                      )
 181                )))))
 182
 183
 184 ;;; @ end
 185 ;;;
 186
 187 (provide 'atype)
 188
 189 ;;; atype.el ends here