home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / unix / volume10 / comobj.lisp / part01 / ntype-of.l < prev    next >
Encoding:
Text File  |  1987-07-30  |  3.6 KB  |  106 lines
  1. ;;;-*- Mode:LISP; Package: (ntype-of lisp); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.
  5. ;;;
  6. ;;; Use and copying of this software and preparation of derivative works
  7. ;;; based upon this software are permitted.  Any distribution of this
  8. ;;; software or derivative works must comply with all applicable United
  9. ;;; States export control laws.
  10. ;;; 
  11. ;;; This software is made available AS IS, and Xerox Corporation makes no
  12. ;;; warranty about the software, its performance or its conformity to any
  13. ;;; specification.
  14. ;;; 
  15. ;;; Any person obtaining a copy of this software is requested to send their
  16. ;;; name and post office or electronic mail address to:
  17. ;;;   CommonLoops Coordinator
  18. ;;;   Xerox Artifical Intelligence Systems
  19. ;;;   2400 Hanover St.
  20. ;;;   Palo Alto, CA 94303
  21. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  22. ;;;
  23. ;;; Suggestions, comments and requests for improvements are also welcome.
  24. ;;; *************************************************************************
  25. ;;;
  26.  
  27. (in-package 'ntype-of)
  28.  
  29. (defvar *portable-types*
  30.   `(number
  31.     (ratio 1/2)
  32.     (complex #c(1 2) complexp)
  33.     ((integer fixnum bignum) 1 integerp)
  34.     ((float short-float single-float double-float long-float) 1.1 floatp)
  35.     (null () null)
  36.     ((character standard-char string-char) #\a characterp)
  37.     (simple-bit-vector #*101 simple-bit-vector-p)
  38.     (bit-vector ,(make-array 3 :element-type 'bit) bit-vector-p)
  39.     (simple-array ,(make-array 10))
  40.     (string ,(make-string 3) stringp)
  41.     (simple-vector #(1 2 3))
  42.     (array (make-array 3 :displaced-to (make-array 3)) arrayp)
  43.     ))
  44.  
  45. (defvar *portable-types*
  46.   `(t
  47.     (array (make-array 3 :displaced-to (make-array 3)) arrayp)
  48.     (simple-bit-vector #*101 simple-bit-vector-p)
  49.     (bit-vector ,(make-array 3 :element-type 'bit) bit-vector-p)
  50.     (simple-array ,(make-array 10))
  51.     ))
  52.  
  53. (defvar *portable-type-lattice*)
  54.  
  55. (defstruct (node (:conc-name node-)
  56.          (:constructor make-node (type entry))
  57.          (:print-function
  58.            (lambda (node stream d)
  59.              (declare (ignore d))
  60.              (format stream "#<node ~S ~:S ~:S>"
  61.                  (node-type node)
  62.                  (mapcar #'node-type (node-supers node))
  63.                  (mapcar #'node-type (node-subs node))))))
  64.   type
  65.   supers
  66.   subs
  67.   entry)
  68.  
  69. (defun make-type-lattice ()
  70.   (macrolet ((memq (x l) `(member ,x ,l :test #'eq))
  71.          (delq (x l) `(delete ,x ,l :test #'eq)))
  72.     (flet ((entry-type (entry)                    ;type of an element 
  73.          (cond ((symbolp entry) entry)            ;of *portable-types*
  74.            ((symbolp (car entry)) (car entry))    
  75.            (t (caar entry))))
  76.        (add-super (node super)
  77.          (setf (node-supers node) (cons super (node-supers node))
  78.            (node-subs super) (cons node (node-subs super))))     
  79.        (remove-super (node super)
  80.          (setf (node-supers node) (delq super (node-supers node))
  81.            (node-subs super) (delq node (node-subs super)))))
  82.       (let ((nodes (mapcar #'(lambda (entry)
  83.                    (make-node (entry-type entry) entry))
  84.                *portable-types*)))
  85.     (setq *portable-type-lattice* (find 't nodes :key #'node-type))
  86.     (dolist (n1 nodes)
  87.       (dolist (n2 (cdr (memq n1 nodes)))
  88.         (cond ((subtypep (node-type n1) (node-type n2))
  89.            (add-super n1 n2))
  90.           ((subtypep (node-type n2) (node-type n1))
  91.            (add-super n2 n1)))))
  92.     (dolist (node nodes)
  93.       (dolist (super1 (node-supers node))
  94.         (dolist (super2 (cdr (node-supers node)))
  95.           (unless (eq super1 super2)
  96.         (when (subtypep (node-type super1) (node-type super2))
  97.           (remove-super node super2))))))
  98.     nodes))))
  99.  
  100. (defun prune-type-lattice (lattice subs)
  101.   (cond ((null subs) nil)
  102.     (
  103.  
  104.      )))
  105.  
  106.