home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / lsp / predlib.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-07  |  18.7 KB  |  542 lines
  1. ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  2.  
  3. ;; This file is part of GNU Common Lisp, herein referred to as GCL
  4. ;;
  5. ;; GCL is free software; you can redistribute it and/or modify it under
  6. ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  7. ;; the Free Software Foundation; either version 2, or (at your option)
  8. ;; any later version.
  9. ;; 
  10. ;; GCL is distributed in the hope that it will be useful, but WITHOUT
  11. ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  12. ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  13. ;; License for more details.
  14. ;; 
  15. ;; You should have received a copy of the GNU Library General Public License 
  16. ;; along with GCL; see the file COPYING.  If not, write to the Free Software
  17. ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  18.  
  19.  
  20. ;;;;    predlib.lsp
  21. ;;;;
  22. ;;;;                              predicate routines
  23.  
  24.  
  25. (in-package 'system)
  26.  
  27. (export '(lisp::deftype lisp::typep lisp::subtypep lisp::coerce) 'lisp)
  28.  
  29. (eval-when (compile)
  30. (proclaim '(optimize (safety 2) (space 3)))
  31. )
  32.  
  33. ;;; DEFTYPE macro.
  34. (defmacro deftype (name lambda-list &rest body)
  35.   ;; Replace undefaultized optional parameter X by (X '*).
  36.   (do ((l lambda-list (cdr l))
  37.        (m nil (cons (car l) m)))
  38.       ((null l))
  39.     (when (member (car l) lambda-list-keywords)
  40.       (unless (eq (car l) '&optional) (return nil))
  41.       (setq m (cons '&optional m))
  42.       (setq l (cdr l))
  43.       (do ()
  44.           ((or (null l) (member (car l) lambda-list-keywords)))
  45.         (if (symbolp (car l))
  46.         (setq m (cons (list (car l) ''*) m))
  47.         (setq m (cons (car l) m)))
  48.         (setq l (cdr l)))
  49.       (setq lambda-list (nreconc m l))
  50.       (return nil)))
  51.   `(eval-when (compile eval load)
  52.           (si:putprop ',name
  53.               '(deftype ,name ,lambda-list ,@body)
  54.               'deftype-form)
  55.           (si:putprop ',name
  56.               #'(lambda ,lambda-list ,@body)
  57.               'deftype-definition)
  58.           (si:putprop ',name
  59.               ,(find-documentation body)
  60.               'type-documentation)
  61.           ',name))
  62.  
  63.  
  64. ;;; Some DEFTYPE definitions.
  65. (deftype fixnum ()
  66.   `(integer ,most-negative-fixnum ,most-positive-fixnum))
  67. (deftype bit () '(integer 0 1))
  68. (deftype mod (n)
  69.   `(integer 0 ,(1- n)))
  70. (deftype signed-byte (&optional s)
  71.   (if (eq s '*)
  72.       `(integer * *)
  73.       `(integer ,(- (expt 2 (1- s))) ,(1- (expt 2 (1- s))))))
  74. (deftype unsigned-byte (&optional s)
  75.   (if (eq s '*)
  76.       `(integer 0 *)
  77.       `(integer 0 ,(1- (expt 2 s)))))
  78. (deftype signed-char ()`(signed-byte ,char-size))
  79. (deftype unsigned-char ()`(unsigned-byte ,char-size))
  80. (deftype signed-short ()`(signed-byte ,short-size))
  81. (deftype unsigned-short ()`(unsigned-byte ,short-size))
  82.  
  83.  
  84.  
  85. (deftype vector (&optional element-type size)
  86.   `(array ,element-type (,size)))
  87. (deftype string (&optional size)
  88.   `(vector string-char ,size))
  89. (deftype bit-vector (&optional size)
  90.   `(vector bit ,size))
  91.  
  92. (deftype simple-vector (&optional size)
  93.   `(simple-array t (,size)))
  94. (deftype simple-string (&optional size)
  95.   `(simple-array string-char (,size)))
  96. (deftype simple-bit-vector (&optional size)
  97.   `(simple-array bit (,size)))
  98.  
  99.  
  100.  
  101. (defun simple-array-p (x)
  102.   (and (arrayp x)
  103.        (not (adjustable-array-p x))
  104.        (not (array-has-fill-pointer-p x))
  105.        (not (si:displaced-array-p x))))
  106.  
  107.  
  108. (do ((l '((null . null)
  109.           (symbol . symbolp)
  110.           (keyword . keywordp)
  111.           (atom . atom)
  112.           (cons . consp)
  113.           (list . listp)
  114.           (number . numberp)
  115.           (character . characterp)
  116.           (package . packagep)
  117.           (stream . streamp)
  118.           (pathname . pathnamep)
  119.           (readtable . readtablep)
  120.           (hash-table . hash-table-p)
  121.           (random-state . random-state-p)
  122.           (structure . si:structurep)
  123.           (function . functionp)
  124.           (compiled-function . compiled-function-p)
  125.           (common . commonp)
  126.           )
  127.         (cdr l)))
  128.     ((endp l))
  129.   (si:putprop (caar l) (cdar l) 'type-predicate))
  130.  
  131.  
  132. ;;; TYPEP predicate.
  133. (defun typep (object type &aux tp i tem)
  134.   (if (atom type)
  135.       (setq tp type i nil)
  136.       (setq tp (car type) i (cdr type)))
  137.   (let ((f (get tp 'type-predicate)))
  138.     (when f (return-from typep (funcall f object))))
  139.   (case tp
  140.     (member (member object i))
  141.     (not (not (typep object (car i))))
  142.     (or
  143.      (do ((l i (cdr l)))
  144.          ((null l) nil)
  145.       (when (typep object (car l)) (return t))))
  146.     (and
  147.      (do ((l i (cdr l)))
  148.          ((null l) t)
  149.        (unless (typep object (car l)) (return nil))))
  150.     (satisfies (funcall (car i) object))
  151.     ((t) t)
  152.     ((nil) nil)
  153.     (fixnum (eq (type-of object) 'fixnum))
  154.     (bignum (eq (type-of object) 'bignum))
  155.     (ratio (eq (type-of object) 'ratio))
  156.     (standard-char
  157.      (and (characterp object) (standard-char-p object)))
  158.     (string-char
  159.      (and (characterp object) (string-char-p object)))
  160.     (integer
  161.      (and (integerp object) (in-interval-p object i)))
  162.     (rational
  163.      (and (rationalp object) (in-interval-p object i)))
  164.     (float
  165.      (and (floatp object) (in-interval-p object i)))
  166.     ((short-float)
  167.      (and (eq (type-of object) 'short-float) (in-interval-p object i)))
  168.     ((single-float double-float long-float)
  169.      (and (eq (type-of object) 'long-float) (in-interval-p object i)))
  170.     (complex
  171.      (and (complexp object)
  172. (or (null i)
  173.        (and   (typep (realpart object) (car i))
  174.             ;;wfs--should only have to check one.
  175.             ;;Illegal to mix real and imaginary types!
  176.               (typep (imagpart object) (car i))))
  177.      ))
  178.     (sequence (or (listp object) (vectorp object)))
  179.     (string
  180.      (and (stringp object)
  181.           (or (null i) (match-dimensions (array-dimensions object) i))))
  182.     (bit-vector
  183.      (and (bit-vector-p object)
  184.           (or (null i) (match-dimensions (array-dimensions object) i))))
  185.     (simple-string
  186.      (and (simple-string-p object)
  187.           (or (null i) (match-dimensions (array-dimensions object) i))))
  188.     (simple-bit-vector
  189.      (and (simple-bit-vector-p object)
  190.           (or (null i) (match-dimensions (array-dimensions object) i))))
  191.     (simple-vector
  192.      (and (simple-vector-p object)
  193.           (or (null i) (match-dimensions (array-dimensions object) i))))
  194.     (simple-array
  195.      (and (simple-array-p object)
  196.           (or (endp i) (eq (car i) '*)
  197.               (equal (array-element-type object)(best-array-element-type (car i))))
  198.           (or (endp (cdr i)) (eq (cadr i) '*)
  199.               (match-dimensions (array-dimensions object) (cadr i)))))
  200.     (array
  201.      (and (arrayp object)
  202.           (or (endp i) (eq (car i) '*)
  203.               ;; Or the element type of object should be EQUAL to (car i).
  204.               ;; Is this too strict?
  205.               (equal (array-element-type object) (best-array-element-type (car i))))
  206.           (or (endp (cdr i)) (eq (cadr i) '*)
  207.               (match-dimensions (array-dimensions object) (cadr i)))))
  208.     (t
  209.      (cond ((setq tem (get tp 'si::s-data))
  210.         (structure-subtype-p object tem))
  211.            ((get tp 'deftype-definition)
  212.             (typep object
  213.                    (apply (get tp 'deftype-definition) i)))))))
  214.  
  215.  
  216. ;;; NORMALIZE-TYPE normalizes the type using the DEFTYPE definitions.
  217. ;;; The result is always a list.
  218. (defun normalize-type (type &aux tp i )
  219.   ;; Loops until the car of type has no DEFTYPE definition.
  220.   (loop
  221.     (if (atom type)
  222.         (setq tp type i nil)
  223.         (setq tp (car type) i (cdr type)))
  224.     (if (get tp 'deftype-definition)
  225.         (setq type (apply (get tp 'deftype-definition) i))
  226.         (return-from normalize-type (if (atom type) (list type) type)))))
  227.  
  228.  
  229. ;;; KNOWN-TYPE-P answers if the given type is a known base type.
  230. ;;; The type may not be normalized.
  231. (defun known-type-p (type)
  232.   (when (consp type) (setq type (car type)))
  233.   (if (or (member type
  234.                   '(t nil null symbol keyword atom cons list sequence
  235.               signed-char unsigned-char signed-short unsigned-short
  236.                     number integer bignum rational ratio float
  237.                     short-float single-float double-float long-float complex
  238.                     character standard-char string-char
  239.                     package stream pathname readtable hash-table random-state
  240.                     structure array simple-array function compiled-function))
  241.           (get type 's-data))
  242.       t
  243.       nil))
  244.  
  245.  
  246. ;;; SUBTYPEP predicate.
  247. (defun subtypep (type1 type2 &aux t1 t2 i1 i2 ntp1 ntp2 tem)
  248.   (setq type1 (normalize-type type1))
  249.   (setq type2 (normalize-type type2))  
  250.   (when (equal type1 type2)
  251.     (return-from subtypep (values t t)))
  252.   (setq t1 (car type1) t2 (car type2))
  253.   (setq i1 (cdr type1) i2 (cdr type2))
  254.   (cond ((eq t1 'member)
  255.          (dolist (e i1)
  256.            (unless (typep e type2) (return-from subtypep (values nil t))))
  257.          (return-from subtypep (values t t)))
  258.         ((eq t1 'or)
  259.          (dolist (tt i1)
  260.            (multiple-value-bind (tv flag) (subtypep tt type2)
  261.              (unless tv (return-from subtypep (values tv flag)))))
  262.          (return-from subtypep (values t t)))
  263.         ((eq t1 'and)
  264.          (dolist (tt i1)
  265.            (let ((tv (subtypep tt type2)))
  266.              (when tv (return-from subtypep (values t t)))))
  267.          (return-from subtypep (values nil nil)))
  268.         ((eq t1 'not)
  269.      ;;
  270.      (return-from subtypep
  271.               (if (eq t2 'not)
  272.               (subtypep (car i2) (car i1))
  273.             (subtypep t `(or ,type2 ,(car i1)))))))
  274.   (cond ((eq t2 'member)
  275.          (return-from subtypep (values nil nil)))
  276.         ((eq t2 'or)
  277.          (dolist (tt i2)
  278.            (let ((tv (subtypep type1 tt)))
  279.              (when tv (return-from subtypep (values t t)))))
  280.          (return-from subtypep (values nil nil)))
  281.         ((eq t2 'and)
  282.          (dolist (tt i2)
  283.            (multiple-value-bind (tv flag) (subtypep type1 tt)
  284.              (unless tv (return-from subtypep (values tv flag)))))
  285.          (return-from subtypep (values t t)))
  286.         ((eq t2 'not)
  287.      (return-from subtypep (subtypep `(and ,type1 ,(car i2)) nil))))
  288.     
  289.   (setq ntp1 (known-type-p type1) ntp2 (known-type-p type2))
  290.   (cond    ((or (eq t1 'nil) (eq t2 't) (eq t2 'common)) (values t t))
  291.            ((eq t2 'nil) (values nil ntp1))
  292.            ((eq t1 't) (values nil ntp2))
  293.            ((eq t1 'common) (values nil ntp2))
  294.            ((eq t2 'list)
  295.             (cond ((member t1 '(null cons list)) (values t t))
  296.                   (t (values nil ntp1))))
  297.            ((eq t2 'sequence)
  298.             (cond ((member t1 '(null cons list sequence)) (values t t))
  299.                   ((eq t1 'array)
  300.                    (if (and (cdr i1) (consp (cadr i1)) (null (cdadr i1)))
  301.                        (values t t)
  302.                        (values nil t)))
  303.                   (t (values nil ntp1))))
  304.            ((eq t1 'list) (values nil ntp2))
  305.            ((eq t1 'sequence) (values nil ntp2))
  306.            ((eq t2 'atom)
  307.             (cond ((member t1 '(cons list)) (values nil t))
  308.                   (ntp1 (values t t))
  309.                   (t (values nil nil))))
  310.            ((eq t1 'atom) (values nil ntp2))
  311.            ((eq t2 'symbol)
  312.             (if (member t1 '(symbol keyword null))
  313.                 (values t t)
  314.                 (values nil ntp1)))
  315.            ((eq t2 'keyword)
  316.             (if (eq t1 'keyword) (values t t) (values nil ntp1)))
  317.            ((eq t2 'null)
  318.             (if (eq t1 'null) (values t t) (values nil ntp1)))
  319.            ((eq t2 'number)
  320.      (cond ((member t1 '(bignum integer ratio rational float
  321.                          short-float single-float double-float long-float
  322.                          complex number))
  323.             (values t t))
  324.            (t (values nil ntp1))))
  325.            ((eq t1 'number) (values nil ntp2))
  326.            ((eq t2 'structure)
  327.             (if (or (eq t1 'structure) (get t1 'si::s-data))
  328.                 (values t t)
  329.                 (values nil ntp1)))
  330.            ((eq t1 'structure) (values nil ntp2))
  331.            ((setq tem (get t1 'si::s-data))
  332.      (let ((tem2 (get t2 'si::s-data)))
  333.        (cond (tem2
  334.            (do ((tp1 tem (s-data-includes tp1)) (tp2 tem2))
  335.                ((null tp1)(values nil t))
  336.                (when (eq tp1 tp2) (return (values t t)))))
  337.          (t (values nil ntp2)))))
  338.            ((get t2 'si::s-data) (values nil ntp1))
  339.            (t
  340.             (case t1
  341.               (bignum
  342.                (case t2
  343.                  (bignum (values t t))
  344.                  ((integer rational)
  345.                   (if (sub-interval-p '(* *) i2)
  346.                       (values t t)
  347.                       (values nil t)))
  348.                  (t (values nil ntp2))))
  349.               (ratio
  350.                (case t2
  351.                  (ratio (values t t))
  352.                  (rational
  353.                   (if (sub-interval-p '(* *) i2) (values t t) (values nil t)))
  354.                  (t (values nil ntp2))))
  355.               (standard-char
  356.         (if (member t2 '(standard-char string-char character))
  357.             (values t t)
  358.             (values nil ntp2)))
  359.        (string-char
  360.         (if (member t2 '(string-char character))
  361.             (values t t)
  362.             (values nil ntp2)))
  363.        (integer
  364.         (if (member t2 '(integer rational))
  365.         (values (sub-interval-p i1 i2) t)
  366.         (values nil ntp2)))
  367.        (rational
  368.         (if (eq t2 'rational)
  369.         (values (sub-interval-p i1 i2) t)
  370.         (values nil ntp2)))
  371.        (float
  372.         (if (eq t2 'float)
  373.         (values (sub-interval-p i1 i2) t)
  374.         (values nil ntp2)))
  375.        ((short-float)
  376.         (if (member t2 '(short-float float))
  377.         (values (sub-interval-p i1 i2) t)
  378.         (values nil ntp2)))
  379.        ((single-float double-float long-float)
  380.         (if (member t2 '(single-float double-float long-float float))
  381.         (values (sub-interval-p i1 i2) t)
  382.         (values nil ntp2)))
  383.        (complex
  384.         (if (eq t2 'complex)
  385.         (subtypep (or (car i1) t) (or (car i2) t))
  386.             (values nil ntp2)))
  387.        (simple-array
  388.         (cond ((or (eq t2 'simple-array) (eq t2 'array))
  389.                (if (or (endp i1) (eq (car i1) '*))
  390.                    (unless (or (endp i2) (eq (car i2) '*))
  391.                            (return-from subtypep (values nil t)))
  392.                    (unless (or (endp i2) (eq (car i2) '*))
  393.                            (unless (equal (car i1) (car i2))
  394.                                    ;; Unless the element type matches,
  395.                                    ;;  return NIL T.
  396.                                    ;; Is this too strict?
  397.                                    (return-from subtypep
  398.                                                 (values nil t)))))
  399.                (when (or (endp (cdr i1)) (eq (cadr i1) '*))
  400.                  (if (or (endp (cdr i2)) (eq (cadr i2) '*))
  401.                      (return-from subtypep (values t t))
  402.                      (return-from subtypep (values nil t))))
  403.            (when (or (endp (cdr i2)) (eq (cadr i2) '*))
  404.                  (return-from subtypep (values t t)))
  405.            (values (match-dimensions (cadr i1) (cadr i2)) t))
  406.               (t (values nil ntp2))))
  407.        (array
  408.         (cond ((eq t2 'array)
  409.                (if (or (endp i1) (eq (car i1) '*))
  410.                    (unless (or (endp i2) (eq (car i2) '*))
  411.                            (return-from subtypep (values nil t)))
  412.                    (unless (or (endp i2) (eq (car i2) '*))
  413.                            (unless (equal (car i1) (car i2))
  414.                                    (return-from subtypep
  415.                                                 (values nil t)))))
  416.                (when (or (endp (cdr i1)) (eq (cadr i1) '*))
  417.                  (if (or (endp (cdr i2)) (eq (cadr i2) '*))
  418.                      (return-from subtypep (values t t))
  419.                      (return-from subtypep (values nil t))))
  420.            (when (or (endp (cdr i2)) (eq (cadr i2) '*))
  421.                  (return-from subtypep (values t t)))
  422.            (values (match-dimensions (cadr i1) (cadr i2)) t))
  423.               (t (values nil ntp2))))
  424.        (t (if ntp1 (values (eq t1 t2) t) (values nil nil)))))))
  425.  
  426.  
  427. (defun sub-interval-p (i1 i2)
  428.   (let (low1 high1 low2 high2)
  429.     (if (endp i1)
  430.         (setq low1 '* high1 '*)
  431.         (if (endp (cdr i1))
  432.             (setq low1 (car i1) high1 '*)
  433.             (setq low1 (car i1) high1 (cadr i1))))
  434.     (if (endp i2)
  435.         (setq low2 '* high2 '*)
  436.         (if (endp (cdr i2))
  437.             (setq low2 (car i2) high2 '*)
  438.             (setq low2 (car i2) high2 (cadr i2))))
  439.     (cond ((eq low1 '*)
  440.        (unless (eq low2 '*)
  441.                (return-from sub-interval-p nil)))
  442.           ((eq low2 '*))
  443.       ((consp low1)
  444.        (if (consp low2)
  445.            (when (< (car low1) (car low2))
  446.              (return-from sub-interval-p nil))
  447.            (when (< (car low1) low2)
  448.              (return-from sub-interval-p nil))))
  449.       ((if (consp low2)
  450.            (when (<= low1 (car low2))
  451.              (return-from sub-interval-p nil))
  452.            (when (< low1 low2)
  453.              (return-from sub-interval-p nil)))))
  454.     (cond ((eq high1 '*)
  455.        (unless (eq high2 '*)
  456.                (return-from sub-interval-p nil)))
  457.           ((eq high2 '*))
  458.       ((consp high1)
  459.        (if (consp high2)
  460.            (when (> (car high1) (car high2))
  461.              (return-from sub-interval-p nil))
  462.            (when (> (car high1) high2)
  463.              (return-from sub-interval-p nil))))
  464.       ((if (consp high2)
  465.            (when (>= high1 (car high2))
  466.              (return-from sub-interval-p nil))
  467.            (when (> high1 high2)
  468.              (return-from sub-interval-p nil)))))
  469.     (return-from sub-interval-p t)))
  470.  
  471. (defun in-interval-p (x interval)
  472.   (let (low high)
  473.     (if (endp interval)
  474.         (setq low '* high '*)
  475.         (if (endp (cdr interval))
  476.             (setq low (car interval) high '*)
  477.             (setq low (car interval) high (cadr interval))))
  478.     (cond ((eq low '*))
  479.           ((consp low)
  480.            (when (<= x (car low)) (return-from in-interval-p nil)))
  481.           ((when (< x low) (return-from in-interval-p nil))))
  482.     (cond ((eq high '*))
  483.           ((consp high)
  484.            (when (>= x (car high)) (return-from in-interval-p nil)))
  485.           ((when (> x high) (return-from in-interval-p nil))))
  486.     (return-from in-interval-p t)))
  487.  
  488. (defun match-dimensions (dim pat)
  489.   (if (null dim)
  490.       (null pat)
  491.       (and (or (eq (car pat) '*)
  492.            (eq (car dim) (car pat)))
  493.        (match-dimensions (cdr dim) (cdr pat)))))
  494.  
  495.  
  496.  
  497. ;;; COERCE function.
  498. (defun coerce (object type)
  499.   (when (typep object type)
  500.         ;; Just return as it is.
  501.         (return-from coerce object))
  502.   (setq type (normalize-type type))
  503.   (case (car type)
  504.     (list
  505.      (do ((l nil (cons (elt object i) l))
  506.           (i (1- (length object)) (1- i)))
  507.          ((< i 0) l)))
  508.     ((array simple-array)
  509.      (unless (or (endp (cdr type))
  510.                  (endp (cddr type))
  511.                  (eq (caddr type) '*)
  512.                  (endp (cdr (caddr type))))
  513.              (error "Cannot coerce to an multi-dimensional array."))
  514.      (do ((seq (make-sequence type (length object)))
  515.           (i 0 (1+ i))
  516.           (l (length object)))
  517.          ((>= i l) seq)
  518.        (setf (elt seq i) (elt object i))))
  519.     (character (character object))
  520.     (float (float object))
  521.     ((short-float) (float object 0.0S0))
  522.     ((single-float double-float long-float) (float object 0.0L0))
  523.     (complex
  524.      (if (or (null (cdr type)) (null (cadr type)) (eq (cadr type) '*))
  525.          (complex (realpart object) (imagpart object))
  526.          (complex (coerce (realpart object) (cadr type))
  527.                   (coerce (imagpart object) (cadr type)))))
  528.     (t (error "Cannot coerce ~S to ~S." object type))))
  529.  
  530. ;; set by unixport/init_kcl.lsp
  531. ;; warn if a file was comopiled in another version
  532. (defvar *gcl-version* nil)
  533.  
  534. (defun warn-version (x)
  535.   (and *gcl-version*
  536.        (not (eql x *gcl-version*))
  537.        *load-verbose*
  538.        (format t "[compiled in GCL 1-~a] " x)))
  539.  
  540.  
  541.  
  542.