home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / Misc / CLISP-2.LHA / CLISP960530-fa.lha / type.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1996-04-15  |  34.0 KB  |  886 lines
  1. ;;;; TYPEP und Verwandtes
  2. ;;;; Michael Stoll, 21. 10. 1988
  3. ;;;; Bruno Haible, 10.6.1989
  4.  
  5. ;;; Datenstrukturen für TYPEP:
  6. ;;; - Ein Type-Specifier-Symbol hat auf seiner Propertyliste unter dem
  7. ;;;   Indikator SYS::TYPE-SYMBOL eine Funktion von einem Argument, die
  8. ;;;   testet, ob ein Objekt vom richtigen Typ ist.
  9. ;;; - Ein Symbol, das eine Type-Specifier-Liste beginnen kann, hat auf seiner
  10. ;;;   Propertyliste unter dem Indikator SYS::TYPE-LIST eine Funktion von
  11. ;;;   einem Argument für das zu testende Objekt und zusätzlichen Argumenten
  12. ;;;   für die Listenelemente.
  13. ;;; - Ein Symbol, das als Typmacro definiert wurde, hat auf seiner Property-
  14. ;;;   liste unter dem Indikator SYSTEM::DEFTYPE-EXPANDER den zugehörigen
  15. ;;;   Expander: eine Funktion, die den zu expandierenden Type-Specifier (eine
  16. ;;;   mindestens einelementige Liste) als Argument bekommt.
  17.  
  18. (in-package "SYSTEM")
  19.  
  20. ; vorläufig, solange bis clos.lsp geladen wird:
  21. (unless (fboundp 'clos::built-in-class-p)
  22.   (defun clos::built-in-class-p (object) (declare (ignore object)) nil)
  23.   (defun clos::subclassp (class1 class2) (declare (ignore class1 class2)) nil)
  24. )
  25.  
  26. (defun typespec-error (fun type)
  27.   (error-of-type 'error
  28.     #L{
  29.     DEUTSCH "~S: ~S ist keine zugelassene Typspezifikation."
  30.     ENGLISH "~S: invalid type specification ~S"
  31.     FRANCAIS "~S : ~S n'est pas une spécification de type légale."
  32.     }
  33.     fun type
  34. ) )
  35.  
  36. ;;; TYPEP, CLTL S. 72, S. 42-51
  37. (defun typep (x y &aux f) ; x = Objekt, y = Typ
  38.   (cond
  39.     ((symbolp y)
  40.        (cond ((setq f (get y 'TYPE-SYMBOL)) (funcall f x))
  41.              ((setq f (get y 'TYPE-LIST)) (funcall f x))
  42.              ((setq f (get y 'DEFTYPE-EXPANDER)) (typep x (funcall f (list y))))
  43.              ((get y 'DEFSTRUCT-DESCRIPTION) (%STRUCTURE-TYPE-P y x))
  44.              ((and (setf f (get y 'CLOS::CLASS))
  45.                    (clos::class-p f)
  46.                    (eq (clos:class-name f) y)
  47.               )
  48.               (clos::subclassp (clos:class-of x) f)
  49.              )
  50.              (t (typespec-error 'typep y))
  51.     )  )
  52.     ((and (consp y) (symbolp (first y)))
  53.        (cond
  54.          ((and (eq (first y) 'SATISFIES) (eql (length y) 2))
  55.             (unless (symbolp (second y))
  56.               (error-of-type 'error
  57.                 #L{
  58.                 DEUTSCH "~S: Argument zu SATISFIES muß Symbol sein: ~S"
  59.                 ENGLISH "~S: argument to SATISFIES must be a symbol: ~S"
  60.                 FRANCAIS "~S : L'argument de SATISFIES doit être un symbole: ~S"
  61.                 }
  62.                 'typep (second y)
  63.             ) )
  64.             (if (funcall (symbol-function (second y)) x) t nil)
  65.          )
  66.          ((eq (first y) 'MEMBER)
  67.             (if (member x (rest y)) t nil)
  68.          )
  69.          ((and (eq (first y) 'EQL) (eql (length y) 2))
  70.             (eql x (second y))
  71.          )
  72.          ((and (eq (first y) 'NOT) (eql (length y) 2))
  73.             (not (typep x (second y)))
  74.          )
  75.          ((eq (first y) 'AND)
  76.             (dolist (type (rest y) t)
  77.               (unless (typep x type) (return nil))
  78.          )  )
  79.          ((eq (first y) 'OR)
  80.             (dolist (type (rest y) nil)
  81.               (when (typep x type) (return t))
  82.          )  )
  83.          ((setq f (get (first y) 'TYPE-LIST)) (apply f x (rest y)))
  84.          ((setq f (get (first y) 'DEFTYPE-EXPANDER)) (typep x (funcall f y)))
  85.          (t (typespec-error 'typep y))
  86.     )  )
  87.     ((clos::class-p y) (clos::subclassp (clos:class-of x) y))
  88.     (t (typespec-error 'typep y))
  89. ) )
  90.  
  91. ; CLTL S. 43
  92. (%put 'ARRAY 'TYPE-SYMBOL #'arrayp)
  93. (%put 'ATOM 'TYPE-SYMBOL #'atom)
  94. (%put 'BIGNUM 'TYPE-SYMBOL
  95.   (function type-symbol-bignum
  96.     (lambda (x) (and (integerp x) (not (fixnump x))))
  97. ) )
  98. (%put 'BIT 'TYPE-SYMBOL
  99.   (function type-symbol-bit
  100.     (lambda (x) (or (eql x 0) (eql x 1)))
  101. ) )
  102. (%put 'BIT-VECTOR 'TYPE-SYMBOL #'bit-vector-p)
  103. (%put 'CHARACTER 'TYPE-SYMBOL #'characterp)
  104. (%put 'COMMON 'TYPE-SYMBOL #'commonp)
  105. (%put 'COMPILED-FUNCTION 'TYPE-SYMBOL #'compiled-function-p)
  106. (%put 'COMPLEX 'TYPE-SYMBOL #'complexp)
  107. (%put 'CONS 'TYPE-SYMBOL #'consp)
  108. (%put 'DOUBLE-FLOAT 'TYPE-SYMBOL #'double-float-p)
  109. (%put 'FIXNUM 'TYPE-SYMBOL #'fixnump)
  110. (%put 'FLOAT 'TYPE-SYMBOL #'floatp)
  111. (%put 'FUNCTION 'TYPE-SYMBOL #'functionp)
  112. (%put 'HASH-TABLE 'TYPE-SYMBOL #'hash-table-p)
  113. (%put 'INTEGER 'TYPE-SYMBOL #'integerp)
  114. (%put 'KEYWORD 'TYPE-SYMBOL #'keywordp)
  115. (%put 'LIST 'TYPE-SYMBOL #'listp)
  116. #+LOGICAL-PATHNAMES
  117. (%put 'LOGICAL-PATHNAME 'TYPE-SYMBOL #'logical-pathname-p)
  118. (%put 'LONG-FLOAT 'TYPE-SYMBOL #'long-float-p)
  119. (%put 'NIL 'TYPE-SYMBOL
  120.   (function type-symbol-nil
  121.     (lambda (x) (declare (ignore x)) nil)
  122. ) )
  123. (%put 'NULL 'TYPE-SYMBOL #'null)
  124. (%put 'NUMBER 'TYPE-SYMBOL #'numberp)
  125. (%put 'PACKAGE 'TYPE-SYMBOL #'packagep)
  126. (%put 'PATHNAME 'TYPE-SYMBOL #'pathnamep)
  127. (%put 'RANDOM-STATE 'TYPE-SYMBOL #'random-state-p)
  128. (%put 'RATIO 'TYPE-SYMBOL
  129.   (function type-symbol-ratio
  130.     (lambda (x) (and (rationalp x) (not (integerp x))))
  131. ) )
  132. (%put 'RATIONAL 'TYPE-SYMBOL #'rationalp)
  133. (%put 'READTABLE 'TYPE-SYMBOL #'readtablep)
  134. (%put 'REAL 'TYPE-SYMBOL #'realp)
  135. (%put 'SEQUENCE 'TYPE-SYMBOL #'sequencep)
  136. (%put 'SHORT-FLOAT 'TYPE-SYMBOL #'short-float-p)
  137. (%put 'SIMPLE-ARRAY 'TYPE-SYMBOL #'simple-array-p)
  138. (%put 'SIMPLE-BIT-VECTOR 'TYPE-SYMBOL #'simple-bit-vector-p)
  139. (%put 'SIMPLE-STRING 'TYPE-SYMBOL #'simple-string-p)
  140. (%put 'SIMPLE-VECTOR 'TYPE-SYMBOL #'simple-vector-p)
  141. (%put 'SINGLE-FLOAT 'TYPE-SYMBOL #'single-float-p)
  142. (%put 'STANDARD-CHAR 'TYPE-SYMBOL
  143.   (function type-symbol-standard-char
  144.     (lambda (x) (and (characterp x) (standard-char-p x)))
  145. ) )
  146. (%put 'CLOS:STANDARD-GENERIC-FUNCTION 'TYPE-SYMBOL #'clos::generic-function-p)
  147. (%put 'CLOS:STANDARD-OBJECT 'TYPE-SYMBOL #'clos::std-instance-p)
  148. (%put 'STREAM 'TYPE-SYMBOL #'streamp)
  149. (%put 'FILE-STREAM 'TYPE-SYMBOL #'file-stream-p)
  150. (%put 'SYNONYM-STREAM 'TYPE-SYMBOL #'synonym-stream-p)
  151. (%put 'BROADCAST-STREAM 'TYPE-SYMBOL #'broadcast-stream-p)
  152. (%put 'CONCATENATED-STREAM 'TYPE-SYMBOL #'concatenated-stream-p)
  153. (%put 'TWO-WAY-STREAM 'TYPE-SYMBOL #'two-way-stream-p)
  154. (%put 'ECHO-STREAM 'TYPE-SYMBOL #'echo-stream-p)
  155. (%put 'STRING-STREAM 'TYPE-SYMBOL #'string-stream-p)
  156. (%put 'STRING 'TYPE-SYMBOL #'stringp)
  157. (%put 'STRING-CHAR 'TYPE-SYMBOL
  158.   (function type-symbol-string-char
  159.     (lambda (x) (and (characterp x) (string-char-p x)))
  160. ) )
  161. (%put 'STRUCTURE 'TYPE-SYMBOL
  162.   (function type-symbol-structure
  163.     (lambda (x)
  164.       (let ((y (type-of x)))
  165.         (and (symbolp y) (get y 'DEFSTRUCT-DESCRIPTION)
  166.              (%STRUCTURE-TYPE-P y x)
  167. ) ) ) ) )
  168. (%put 'SYMBOL 'TYPE-SYMBOL #'symbolp)
  169. (%put 'T 'TYPE-SYMBOL
  170.   (function type-symbol-t
  171.     (lambda (x) (declare (ignore x)) t)
  172. ) )
  173. (%put 'VECTOR 'TYPE-SYMBOL #'vectorp)
  174.  
  175. ; CLTL S. 46-50
  176. (defun upgraded-array-element-type (type)
  177.   ; siehe array.d
  178.   (case type
  179.     ((BIT STRING-CHAR T) type)
  180.     (t (multiple-value-bind (low high) (sys::subtype-integer type)
  181.          ; Es gilt (or (null low) (subtypep type `(INTEGER ,low ,high))
  182.          (if (and (integerp low) (not (minusp low)) (integerp high))
  183.            (let ((l (integer-length high)))
  184.              ; Es gilt (subtypep type `(UNSIGNED-BYTE ,l))
  185.              (cond ((<= l 1) 'BIT)
  186.                    ((<= l 2) '(UNSIGNED-BYTE 2))
  187.                    ((<= l 4) '(UNSIGNED-BYTE 4))
  188.                    ((<= l 8) '(UNSIGNED-BYTE 8))
  189.                    ((<= l 16) '(UNSIGNED-BYTE 16))
  190.                    ((<= l 32) '(UNSIGNED-BYTE 32))
  191.                    (t 'T)
  192.            ) )
  193.            'T
  194.   ) )  ) )
  195. )
  196. (%put 'ARRAY 'TYPE-LIST
  197.   (function type-list-array
  198.     (lambda (x &optional (el-type '*) (dims '*))
  199.       (and (arrayp x)
  200.            (or (eq el-type '*)
  201.                (equal (array-element-type x) (upgraded-array-element-type el-type))
  202.            )
  203.            (or (eq dims '*)
  204.                (if (numberp dims)
  205.                  (eql dims (array-rank x))
  206.                  (and (eql (length dims) (array-rank x))
  207.                       (every #'(lambda (a b) (or (eq a '*) (eql a b)))
  208.                              dims (array-dimensions x)
  209.   ) ) )    )   ) )    )
  210. )
  211. (%put 'SIMPLE-ARRAY 'TYPE-LIST
  212.   (function type-list-simple-array
  213.     (lambda (x &optional (el-type '*) (dims '*))
  214.       (and (simple-array-p x)
  215.            (or (eq el-type '*)
  216.                (equal (array-element-type x) (upgraded-array-element-type el-type))
  217.            )
  218.            (or (eq dims '*)
  219.                (if (numberp dims)
  220.                  (eql dims (array-rank x))
  221.                  (and (eql (length dims) (array-rank x))
  222.                       (every #'(lambda (a b) (or (eq a '*) (eql a b)))
  223.                              dims (array-dimensions x)
  224.   ) ) )    )   ) )    )
  225. )
  226. (%put 'VECTOR 'TYPE-LIST
  227.   (function type-list-vector
  228.     (lambda (x &optional (el-type '*) (size '*))
  229.       (and (vectorp x)
  230.            (or (eq el-type '*)
  231.                (equal (array-element-type x) (upgraded-array-element-type el-type))
  232.            )
  233.            (or (eq size '*) (eql (array-dimension x 0) size))
  234.   ) ) )
  235. )
  236. (%put 'SIMPLE-VECTOR 'TYPE-LIST
  237.   (function type-list-simple-vector
  238.     (lambda (x &optional (size '*))
  239.       (and (simple-vector-p x)
  240.            (or (eq size '*) (eql size (array-dimension x 0)))
  241.   ) ) )
  242. )
  243. (%put 'COMPLEX 'TYPE-LIST
  244.   (function type-list-complex
  245.     (lambda (x &optional (rtype '*) (itype rtype))
  246.       (and (complexp x)
  247.            (or (eq rtype '*) (typep (realpart x) rtype))
  248.            (or (eq itype '*) (typep (imagpart x) itype))
  249.   ) ) )
  250. )
  251. (%put 'INTEGER 'TYPE-LIST
  252.   (function type-list-integer
  253.     (lambda (x &optional (low '*) (high '*))
  254.       (typep-number-test x low high #'integerp 'INTEGER)
  255.   ) )
  256. )
  257. (defun typep-number-test (x low high test type)
  258.   (and (funcall test x)
  259.        (cond ((eq low '*))
  260.              ((funcall test low) (<= low x))
  261.              ((and (consp low) (null (rest low)) (funcall test (first low)))
  262.                 (< (first low) x)
  263.              )
  264.              (t (error-of-type 'error
  265.                   #L{
  266.                   DEUTSCH "~S: Argument zu ~S muß *, ~S oder eine Liste von ~S sein: ~S"
  267.                   ENGLISH "~S: argument to ~S must be *, ~S or a list of ~S: ~S"
  268.                   FRANCAIS "~S : L'argument de ~S doit être *, ~S ou une liste de ~S: ~S"
  269.                   }
  270.                   'typep type type type low
  271.        )     )  )
  272.        (cond ((eq high '*))
  273.              ((funcall test high) (>= high x))
  274.              ((and (consp high) (null (rest high)) (funcall test (first high)))
  275.                 (> (first high) x)
  276.              )
  277.              (t (error-of-type 'error
  278.                   #L{
  279.                   DEUTSCH "~S: Argument zu ~S muß *, ~S oder eine Liste von ~S sein: ~S"
  280.                   ENGLISH "~S: argument to ~S must be *, ~S or a list of ~S: ~S"
  281.                   FRANCAIS "~S : L'argument de ~S doit être *, ~S ou une liste de ~S: ~S"
  282.                   }
  283.                   'typep type type type high
  284. ) )    )     )  )
  285. (%put 'MOD 'TYPE-LIST
  286.   (function type-list-mod
  287.     (lambda (x n)
  288.       (unless (integerp n)
  289.         (error-of-type 'error
  290.           #L{
  291.           DEUTSCH "~S: Argument zu MOD muß ganze Zahl sein: ~S"
  292.           ENGLISH "~S: argument to MOD must be an integer: ~S"
  293.           FRANCAIS "~S : L'argument de MOD doit être un entier: ~S"
  294.           }
  295.           'typep n
  296.       ) )
  297.       (and (integerp x) (<= 0 x) (< x n))
  298.   ) )
  299. )
  300. (%put 'SIGNED-BYTE 'TYPE-LIST
  301.   (function type-list-signed-byte
  302.     (lambda (x &optional (n '*))
  303.       (unless (or (eq n '*) (integerp n))
  304.         (error-of-type 'error
  305.           #L{
  306.           DEUTSCH "~S: Argument zu SIGNED-BYTE muß ganze Zahl oder * sein: ~S"
  307.           ENGLISH "~S: argument to SIGNED-BYTE must be an integer or * : ~S"
  308.           FRANCAIS "~S : L'argument de SIGNED-BYTE doit être un entier ou bien * : ~S"
  309.           }
  310.           'typep n
  311.       ) )
  312.       (and (integerp x) (or (eq n '*) (< (integer-length x) n)))
  313.   ) )
  314. )
  315. (%put 'UNSIGNED-BYTE 'TYPE-LIST
  316.   (function type-list-unsigned-byte
  317.     (lambda (x &optional (n '*))
  318.       (unless (or (eq n '*) (integerp n))
  319.         (error-of-type 'error
  320.           #L{
  321.           DEUTSCH "~S: Argument zu UNSIGNED-BYTE muß ganze Zahl oder * sein: ~S"
  322.           ENGLISH "~S: argument to UNSIGNED-BYTE must be an integer or * : ~S"
  323.           FRANCAIS "~S : L'argument de UNSIGNED-BYTE doit être un entier ou bien * : ~S"
  324.           }
  325.           'typep n
  326.       ) )
  327.       (and (integerp x)
  328.            (not (minusp x))
  329.            (or (eq n '*) (<= (integer-length x) n))
  330.   ) ) )
  331. )
  332. (%put 'REAL 'TYPE-LIST
  333.   (function type-list-real
  334.     (lambda (x &optional (low '*) (high '*))
  335.       (typep-number-test x low high #'realp 'REAL)
  336.   ) )
  337. )
  338. (%put 'RATIONAL 'TYPE-LIST
  339.   (function type-list-rational
  340.     (lambda (x &optional (low '*) (high '*))
  341.       (typep-number-test x low high #'rationalp 'RATIONAL)
  342.   ) )
  343. )
  344. (%put 'FLOAT 'TYPE-LIST
  345.   (function type-list-float
  346.     (lambda (x &optional (low '*) (high '*))
  347.       (typep-number-test x low high #'floatp 'FLOAT)
  348.   ) )
  349. )
  350. (%put 'SHORT-FLOAT 'TYPE-LIST
  351.   (function type-list-short-float
  352.     (lambda (x &optional (low '*) (high '*))
  353.       (typep-number-test x low high #'short-float-p 'SHORT-FLOAT)
  354.   ) )
  355. )
  356. (%put 'SINGLE-FLOAT 'TYPE-LIST
  357.   (function type-list-single-float
  358.     (lambda (x &optional (low '*) (high '*))
  359.       (typep-number-test x low high #'single-float-p 'SINGLE-FLOAT)
  360.   ) )
  361. )
  362. (%put 'DOUBLE-FLOAT 'TYPE-LIST
  363.   (function type-list-double-float
  364.     (lambda (x &optional (low '*) (high '*))
  365.       (typep-number-test x low high #'double-float-p 'DOUBLE-FLOAT)
  366.   ) )
  367. )
  368. (%put 'LONG-FLOAT 'TYPE-LIST
  369.   (function type-list-long-float
  370.     (lambda (x &optional (low '*) (high '*))
  371.       (typep-number-test x low high #'long-float-p 'LONG-FLOAT)
  372.   ) )
  373. )
  374. (%put 'STRING 'TYPE-LIST
  375.   (function type-list-string
  376.     (lambda (x &optional (size '*))
  377.       (and (stringp x)
  378.            (or (eq size '*) (eql size (array-dimension x 0)))
  379.   ) ) )
  380. )
  381. (%put 'SIMPLE-STRING 'TYPE-LIST
  382.   (function type-list-simple-string
  383.     (lambda (x &optional (size '*))
  384.       (and (simple-string-p x)
  385.            (or (eq size '*) (eql size (array-dimension x 0)))
  386.   ) ) )
  387. )
  388. (%put 'BIT-VECTOR 'TYPE-LIST
  389.   (function type-list-bit-vector
  390.     (lambda (x &optional (size '*))
  391.       (and (bit-vector-p x)
  392.            (or (eq size '*) (eql size (array-dimension x 0)))
  393.   ) ) )
  394. )
  395. (%put 'SIMPLE-BIT-VECTOR 'TYPE-LIST
  396.   (function type-list-simple-bit-vector
  397.     (lambda (x &optional (size '*))
  398.       (and (simple-bit-vector-p x)
  399.            (or (eq size '*) (eql size (array-dimension x 0)))
  400.   ) ) )
  401. )
  402.  
  403. ; Typtest ohne Gefahr einer Fehlermeldung. Für SIGNAL und HANDLER-BIND.
  404. (defun safe-typep (x y)
  405.   (let ((*error-handler*
  406.           #'(lambda (&rest error-args)
  407.               (declare (ignore error-args))
  408.               (return-from safe-typep nil)
  409.        ))   )
  410.     (typep x y)
  411. ) )
  412.  
  413. ; Testet eine Liste von Werten auf Erfüllen eines Type-Specifiers. Für THE.
  414. (defun %the (values type)
  415.   (if (and (consp type) (eq (car type) 'VALUES))
  416.     (macrolet ((typespec-error ()
  417.                  '(error-of-type 'error
  418.                    #L{
  419.                    DEUTSCH "Falsch aufgebauter Type-Specifier: ~S"
  420.                    ENGLISH "Invalid type specifier ~S"
  421.                    FRANCAIS "Spécificateur de type mal formé : ~S"
  422.                    }
  423.                    type
  424.               ))  )
  425.       (let ((vals values)
  426.             (types (cdr type)))
  427.         ; required-Werte:
  428.         (loop
  429.           (when (or (atom types) (member (car types) lambda-list-keywords :test #'eq))
  430.             (return)
  431.           )
  432.           (unless (and (consp vals) (typep (car vals) (car types)))
  433.             (return-from %the nil)
  434.           )
  435.           (setq vals (cdr vals))
  436.           (setq types (cdr types))
  437.         )
  438.         ; optionale Werte:
  439.         (when (and (consp types) (eq (car types) '&optional))
  440.           (setq types (cdr types))
  441.           (loop
  442.             (when (or (atom types) (member (car types) lambda-list-keywords :test #'eq))
  443.               (return)
  444.             )
  445.             (when (consp vals)
  446.               (unless (typep (car vals) (car types)) (return-from %the nil))
  447.               (setq vals (cdr vals))
  448.             )
  449.             (setq types (cdr types))
  450.         ) )
  451.         ; restliche Werte:
  452.         (if (atom types)
  453.           (when (consp vals) (return-from %the nil))
  454.           (case (car types)
  455.             (&rest
  456.               (setq types (cdr types))
  457.               (when (atom types) (typespec-error))
  458.               (unless (typep vals (car types)) (return-from %the nil))
  459.               (setq types (cdr types))
  460.             )
  461.             (&key)
  462.             (t (typespec-error))
  463.         ) )
  464.         ; Keyword-Werte:
  465.         (when (consp types)
  466.           (if (eq (car types) '&key)
  467.             (progn
  468.               (setq types (cdr types))
  469.               (when (oddp (length vals)) (return-from %the nil))
  470.               (let ((keywords nil))
  471.                 (loop
  472.                   (when (or (atom types) (member (car types) lambda-list-keywords :test #'eq))
  473.                     (return)
  474.                   )
  475.                   (let ((item (car types)))
  476.                     (unless (and (listp item) (eql (length item) 2) (symbolp (first item)))
  477.                       (typespec-error)
  478.                     )
  479.                     (let ((kw (intern (symbol-name (first item)) *keyword-package*)))
  480.                       (unless (typep (getf vals kw) (second item))
  481.                         (return-from %the nil)
  482.                       )
  483.                       (push kw keywords)
  484.                   ) )
  485.                   (setq types (cdr types))
  486.                 )
  487.                 (if (and (consp types) (eq (car types) '&allow-other-keys))
  488.                   (setq types (cdr types))
  489.                   (unless (getf vals ':allow-other-keys)
  490.                     (do ((L vals (cddr L)))
  491.                         ((atom L))
  492.                       (unless (member (car L) keywords :test #'eq)
  493.                         (return-from %the nil)
  494.                 ) ) ) )
  495.             ) )
  496.             (when (consp types) (typespec-error))
  497.         ) )
  498.         t
  499.     ) )
  500.     (typep (if (consp values) (car values) nil) type) ; 1. Wert abtesten
  501. ) )
  502.  
  503. ;;; SUBTYPEP, vorläufige Version
  504. (defun canonicalize-type (type) ; type ein wenig vereinfachen, nicht rekursiv
  505.   (cond ((symbolp type)
  506.          (let ((f (get type 'DEFTYPE-EXPANDER)))
  507.            (if f
  508.              (canonicalize-type (funcall f (list type))) ; macroexpandieren
  509.              (case type
  510.                (ATOM '(NOT CONS))
  511.                (BIGNUM '(AND INTEGER (NOT FIXNUM)))
  512.                (BIT '(INTEGER 0 1))
  513.                (COMMON '(OR CONS SYMBOL NUMBER ARRAY STANDARD-CHAR
  514.                          STREAM PACKAGE HASH-TABLE READTABLE PATHNAME RANDOM-STATE
  515.                          STRUCTURE
  516.                )        )
  517.                (FIXNUM '(INTEGER #,most-negative-fixnum #,most-positive-fixnum))
  518.                (KEYWORD '(AND SYMBOL (SATISFIES KEYWORDP)))
  519.                (LIST '(OR CONS (MEMBER NIL)))
  520.                ((NIL) '(OR))
  521.                (NULL '(MEMBER NIL))
  522.                (RATIO '(AND RATIONAL (NOT INTEGER)))
  523.                (SEQUENCE '(OR LIST VECTOR)) ; user-defined sequences??
  524.                (STANDARD-CHAR '(AND CHARACTER (SATISFIES STRING-CHAR-P) (SATISFIES STANDARD-CHAR-P)))
  525.                (STRING-CHAR '(AND CHARACTER (SATISFIES STRING-CHAR-P)))
  526.                ((T) '(AND))
  527.                ((ARRAY SIMPLE-ARRAY BIT-VECTOR SIMPLE-BIT-VECTOR
  528.                  STRING SIMPLE-STRING VECTOR SIMPLE-VECTOR
  529.                  COMPLEX REAL INTEGER RATIONAL FLOAT
  530.                  SHORT-FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT
  531.                 )
  532.                  (canonicalize-type (list type))
  533.                )
  534.                (t (if (and (setq f (get type 'CLOS::CLASS))
  535.                            (clos::class-p f) (not (clos::built-in-class-p f))
  536.                            (eq (clos:class-name f) type)
  537.                       )
  538.                     f
  539.                     type
  540.         )) ) ) )  )
  541.         ((and (consp type) (symbolp (first type)))
  542.          (let ((f (get (first type) 'DEFTYPE-EXPANDER)))
  543.            (if f
  544.              (canonicalize-type (funcall f type)) ; macroexpandieren
  545.              (case (first type)
  546.                (MEMBER ; (MEMBER &rest objects)
  547.                  (if (null (rest type)) '(OR) type)
  548.                )
  549.                (EQL ; (EQL object)
  550.                  `(MEMBER ,(second type))
  551.                )
  552.                (MOD ; (MOD n)
  553.                  (let ((n (second type)))
  554.                    (unless (and (integerp n) (>= n 0)) (typespec-error 'subtypep type))
  555.                    `(INTEGER 0 (,n))
  556.                ) )
  557.                (SIGNED-BYTE ; (SIGNED-BYTE &optional s)
  558.                  (let ((s (or (second type) '*)))
  559.                    (if (eq s '*)
  560.                      'INTEGER
  561.                      (progn
  562.                        (unless (and (integerp s) (plusp s)) (typespec-error 'subtypep type))
  563.                        (let ((n (expt 2 (1- s))))
  564.                          `(INTEGER ,(- n) (,n))
  565.                ) ) ) ) )
  566.                (UNSIGNED-BYTE ; (UNSIGNED-BYTE &optional s)
  567.                  (let ((s (or (second type) '*)))
  568.                    (if (eq s '*)
  569.                      '(INTEGER 0 *)
  570.                      (progn
  571.                        (unless (and (integerp s) (>= s 0)) (typespec-error 'subtypep type))
  572.                        (let ((n (expt 2 s)))
  573.                          `(INTEGER 0 (,n))
  574.                ) ) ) ) )
  575.                (SIMPLE-BIT-VECTOR ; (SIMPLE-BIT-VECTOR &optional size)
  576.                  (let ((size (or (second type) '*)))
  577.                    `(SIMPLE-ARRAY BIT (,size))
  578.                ) )
  579.                (SIMPLE-STRING ; (SIMPLE-STRING &optional size)
  580.                  (let ((size (or (second type) '*)))
  581.                    `(SIMPLE-ARRAY STRING-CHAR (,size))
  582.                ) )
  583.                (SIMPLE-VECTOR ; (SIMPLE-VECTOR &optional size)
  584.                  (let ((size (or (second type) '*)))
  585.                    `(SIMPLE-ARRAY T (,size))
  586.                ) )
  587.                (BIT-VECTOR ; (BIT-VECTOR &optional size)
  588.                  (let ((size (or (second type) '*)))
  589.                    `(ARRAY BIT (,size))
  590.                ) )
  591.                (STRING ; (STRING &optional size)
  592.                  (let ((size (or (second type) '*)))
  593.                    `(ARRAY STRING-CHAR (,size))
  594.                ) )
  595.                (VECTOR ; (VECTOR &optional el-type size)
  596.                  (let ((el-type (or (second type) '*))
  597.                        (size (or (third type) '*)))
  598.                    `(ARRAY ,el-type (,size))
  599.                ) )
  600.                (t type)
  601.         )) ) )
  602.         ((clos::class-p type)
  603.          (if (and (clos::built-in-class-p type)
  604.                   (eq (get (clos:class-name type) 'CLOS::CLASS) type)
  605.              )
  606.            (canonicalize-type (clos:class-name type))
  607.            type
  608.         ))
  609. ) )
  610. (defun subtypep (type1 type2)
  611.   (macrolet ((yes () '(return-from subtypep (values t t)))
  612.              (no () '(return-from subtypep (values nil t)))
  613.              (unknown () '(return-from subtypep (values nil nil))))
  614.     (setq type1 (canonicalize-type type1))
  615.     (setq type2 (canonicalize-type type2))
  616.     (when (equal type1 type2) (yes)) ; (subtypep type type) stimmt immer
  617.     (when (consp type1)
  618.       (cond ;; über SATISFIES-Typen kann man nichts aussagen
  619.             ;((and (eq (first type1) 'SATISFIES) (eql (length type1) 2))
  620.             ; (unknown)
  621.             ;)
  622.             ;; MEMBER: alle Elemente müssen vom Typ type2 sein
  623.             ((eq (first type1) 'MEMBER)
  624.              (dolist (x (rest type1) (yes))
  625.                (unless (typep x type2) (return (no)))
  626.             ))
  627.             ;; NOT: (subtypep `(NOT ,type1) `(NOT ,type2)) ist äquivalent
  628.             ;; zu (subtypep type2 type1), sonst ist Entscheidung schwierig
  629.             ((and (eq (first type1) 'NOT) (eql (length type1) 2))
  630.              (return-from subtypep
  631.                (if (and (consp type2) (eq (first type2) 'NOT) (eql (length type2) 2))
  632.                  (subtypep (second type2) (second type1))
  633.                  (unknown)
  634.             )) )
  635.             ;; OR: Jeder Typ muß Subtyp von type2 sein
  636.             ((eq (first type1) 'OR)
  637.              (dolist (type (rest type1) (yes))
  638.                (multiple-value-bind (is known) (subtypep type type2)
  639.                  (unless is (return-from subtypep (values nil known)))
  640.             )) )
  641.     ) )
  642.     (when (consp type2)
  643.       (cond ;; über SATISFIES-Typen kann man nichts aussagen
  644.             ;((and (eq (first type2) 'SATISFIES) (eql (length type2) 2))
  645.             ; (unknown)
  646.             ;)
  647.             ;; NOT: siehe oben
  648.             ((and (eq (first type2) 'NOT) (eql (length type2) 2))
  649.              (unknown)
  650.             )
  651.             ;; AND: type1 muß Subtyp jedes der Typen sein
  652.             ((eq (first type2) 'AND)
  653.              (dolist (type (rest type2) (yes))
  654.                (multiple-value-bind (is known) (subtypep type1 type)
  655.                  (unless is (return-from subtypep (values nil known)))
  656.             )) )
  657.             ;; OR: Falls type1 Subtyp eines der Typen ist, sonst nicht bekannt
  658.             ((eq (first type2) 'OR)
  659.              (dolist (type (rest type2) (unknown))
  660.                (when (subtypep type1 type) (return (yes)))
  661.             ))
  662.     ) )
  663.     (when (consp type1)
  664.       (cond ;; AND: Falls ein Typ Subtyp von type2 ist, sonst nicht bekannt
  665.             ((eq (first type1) 'AND)
  666.              (dolist (type (rest type1) (unknown))
  667.                (when (subtypep type type2) (return (yes)))
  668.             ))
  669.     ) )
  670.     (when (and (symbolp type1) (get type1 'DEFSTRUCT-DESCRIPTION)
  671.                (symbolp type2)
  672.           )
  673.       (when (eq type2 'STRUCTURE) (yes))
  674.       (when (get type2 'DEFSTRUCT-DESCRIPTION)
  675.         (let ((inclist1 (svref (get type1 'DEFSTRUCT-DESCRIPTION) 0))
  676.               (inclist2 (svref (get type2 'DEFSTRUCT-DESCRIPTION) 0)))
  677.           (loop
  678.             (when (eq inclist1 inclist2) (return (yes)))
  679.             (when (atom inclist1) (return))
  680.             (setq inclist1 (cdr inclist1))
  681.       ) ) )
  682.     )
  683.     (when (or (clos::class-p type1) (clos::class-p type2))
  684.       (if (and (clos::class-p type1) (clos::class-p type2) (clos::subclassp type1 type2))
  685.         (yes)
  686.         (no)
  687.     ) )
  688.     (when (atom type1) (setq type1 (list type1)))
  689.     (case (first type1)
  690.       ((ARRAY SIMPLE-ARRAY)
  691.         (macrolet ((array-p (type)
  692.                      `(or (eq ,type 'ARRAY) (eq ,type (first type1)))
  693.                   ))
  694.           (let ((el-type1 (if (rest type1) (second type1) '*))
  695.                 (dims1 (if (cddr type1) (third type1) '*)))
  696.             (values
  697.               (cond ((array-p type2) t)
  698.                     ((and (consp type2) (array-p (first type2)))
  699.                      (let ((el-type2 (if (rest type2) (second type2) '*))
  700.                            (dims2 (if (cddr type2) (third type2) '*)))
  701.                        (and (or (eq el-type2 '*)
  702.                                 (and (not (eq el-type1 '*))
  703.                                      (equal (upgraded-array-element-type el-type1)
  704.                                             (upgraded-array-element-type el-type2)
  705.                             )   )    )
  706.                             (or (eq dims2 '*)
  707.                                 (and (listp dims1) (listp dims2)
  708.                                      (eql (length dims1) (length dims2))
  709.                                      (every #'(lambda (a b) (or (eq b '*) (= a b)))
  710.                                               dims1 dims2
  711.                     )) )    )   )    )
  712.                     (t nil)
  713.               )
  714.               t
  715.       ) ) ) )
  716.       (COMPLEX
  717.         (let* ((rtype1 (if (rest type1) (second type1) '*))
  718.                (itype1 (if (cddr type1) (third type1) rtype1)))
  719.           (values
  720.             (cond ((or (eq type2 'COMPLEX) (eq type2 'NUMBER)) t)
  721.                   ((and (consp type2) (eq (first type2) 'COMPLEX))
  722.                    (let* ((rtype2 (if (rest type2) (second type2) '*))
  723.                           (itype2 (if (cddr type2) (third type2) rtype2)))
  724.                      (and (or (eq rtype2 '*)
  725.                               (and (not (eq rtype1 '*))
  726.                                    (subtypep rtype1 rtype2)
  727.                           )   )
  728.                           (or (eq itype2 '*)
  729.                               (and (not (eq itype1 '*))
  730.                                    (subtypep itype1 itype2)
  731.                   )) )    )   )
  732.                   (t nil)
  733.             )
  734.             t
  735.       ) ) )
  736.       ((REAL INTEGER RATIONAL FLOAT SHORT-FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT)
  737.         (let ((typelist
  738.                 (cons (first type1)
  739.                   (case (first type1)
  740.                     (REAL '(NUMBER))
  741.                     (INTEGER '(RATIONAL REAL NUMBER))
  742.                     ((RATIONAL FLOAT) '(REAL NUMBER))
  743.                     ((SHORT-FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT) '(FLOAT REAL NUMBER))
  744.               ) ) )
  745.               (low1 (if (rest type1) (second type1) '*))
  746.               (high1 (if (cddr type1) (third type1) '*))
  747.               (integer-flag1 (eq (first type1) 'INTEGER))
  748.               (efl t)
  749.               (efh t))
  750.           (when (consp low1)
  751.             (setq low1 (first low1))
  752.             (if integer-flag1 (when (numberp low1) (incf low1)) (setq efl nil))
  753.           )
  754.           (when (consp high1)
  755.             (setq high1 (first high1))
  756.             (if integer-flag1 (when (numberp high1) (decf high1)) (setq efh nil))
  757.           )
  758.           ; efl gibt an, ob low1 zu type1 dazugehört.
  759.           ; efh gibt an, ob high1 zu type1 dazugehört.
  760.           (cond ((and (numberp low1) (numberp high1)
  761.                       (not (or (< low1 high1) (and (= low1 high1) efl efh)))
  762.                  ) ; type1 leer?
  763.                  (yes)
  764.                 )
  765.                 ((member type2 typelist) (yes))
  766.                 ((and (consp type2) (member (first type2) typelist))
  767.                  (let ((low2 (if (rest type2) (second type2) '*))
  768.                        (high2 (if (cddr type2) (third type2) '*))
  769.                        (integer-flag2 (eq (first type2) 'INTEGER)))
  770.                    (if (consp low2)
  771.                      (progn (setq low2 (first low2))
  772.                             (when integer-flag2 (when (numberp low2) (incf low2)) (setq efl nil))
  773.                      )
  774.                      (setq efl nil)
  775.                    )
  776.                    (if (consp high2)
  777.                      (progn (setq high2 (first high2))
  778.                             (when integer-flag2 (when (numberp high2) (decf high2)) (setq efh nil))
  779.                      )
  780.                      (setq efh nil)
  781.                    )
  782.                    ; efl gibt an, ob low1 zu type1 dazugehört und low2 zu type2 nicht dazugehört.
  783.                    ; efh gibt an, ob high1 zu type1 dazugehört und high2 zu type2 nicht dazugehört.
  784.                    (values
  785.                      (and (or (eq low2 '*)
  786.                               (and (numberp low1)
  787.                                    (if efl (> low1 low2) (>= low1 low2))
  788.                           )   )
  789.                           (or (eq high2 '*)
  790.                               (and (numberp high1)
  791.                                    (if efh (< high1 high2) (<= high1 high2))
  792.                      )    )   )
  793.                      t
  794.                 )) )
  795.                 (t (values nil (not integer-flag1)))
  796.       ) ) )
  797.       ((CHARACTER CONS FUNCTION HASH-TABLE PACKAGE PATHNAME RANDOM-STATE
  798.         READTABLE STREAM SYMBOL)
  799.        (no)
  800.       )
  801.       (CLOS:STANDARD-GENERIC-FUNCTION (if (eq type2 'FUNCTION) (yes) (no)))
  802.       #+LOGICAL-PATHNAMES
  803.       (LOGICAL-PATHNAME (if (eq type2 'PATHNAME) (yes) (no)))
  804.       ((FILE-STREAM SYNONYM-STREAM BROADCAST-STREAM CONCATENATED-STREAM
  805.         TWO-WAY-STREAM ECHO-STREAM STRING-STREAM)
  806.        (if (eq type2 'STREAM) (yes) (no))
  807.       )
  808.       (t (unknown))
  809. ) ) )
  810.  
  811. ;; Bestimmt zwei Werte low,high so, daß (subtypep type `(INTEGER ,low ,high))
  812. ;; gilt und low möglichst groß und high möglichst klein ist.
  813. ;; low = * bedeutet -unendlich, high = * bedeutet unendlich.
  814. ;; Werte sind NIL,NIL falls (subtypep type 'INTEGER) falsch ist.
  815. ;; Wir brauchen diese Funktion nur für MAKE-ARRAY und UPGRADED-ARRAY-ELEMENT-TYPE,
  816. ;; dürfen also oBdA  type  durch  `(OR ,type (MEMBER 0))  ersetzen.
  817. (defun subtype-integer (type)
  818.   (macrolet ((yes () '(return-from subtype-integer (values low high)))
  819.              (no () '(return-from subtype-integer nil))
  820.              (unknown () '(return-from subtype-integer nil)))
  821.     (setq type (canonicalize-type type))
  822.     (if (consp type)
  823.       (macrolet ((min* (x y) `(if (or (eq ,x '*) (eq ,y '*)) '* (min ,x ,y)))
  824.                  (max* (x y) `(if (or (eq ,x '*) (eq ,y '*)) '* (max ,x ,y))))
  825.         (case (first type)
  826.           (MEMBER ;; MEMBER: alle Elemente müssen vom Typ INTEGER sein
  827.             (let ((low 0) (high 0)) ; oBdA!
  828.               (dolist (x (rest type) (yes))
  829.                 (unless (typep x 'INTEGER) (return (no)))
  830.                 (setq low (min low x) high (max high x))
  831.           ) ) )
  832.           (OR ;; OR: Jeder Typ muß Subtyp von INTEGER sein
  833.             (let ((low 0) (high 0)) ; oBdA!
  834.               (dolist (type1 (rest type) (yes))
  835.                 (multiple-value-bind (low1 high1) (subtype-integer type1)
  836.                   (unless low1 (return (no)))
  837.                   (setq low (min* low low1) high (max* high high1))
  838.           ) ) ) )
  839.           (AND ;; AND: Falls ein Typ Subtyp von INTEGER ist, sonst nicht bekannt
  840.             ;; Hier könnte man die verschiedenen Integer-Subtypen schneiden.
  841.             (dolist (type1 (rest type) (unknown))
  842.               (multiple-value-bind (low high) (subtype-integer type1)
  843.                 (when low (return (yes)))
  844.           ) ) )
  845.       ) )
  846.       (setq type (list type))
  847.     )
  848.     (if (eq (first type) 'INTEGER)
  849.       (let ((low (if (rest type) (second type) '*))
  850.             (high (if (cddr type) (third type) '*)))
  851.         (when (consp low)
  852.           (setq low (first low))
  853.           (when (numberp low) (incf low))
  854.         )
  855.         (when (consp high)
  856.           (setq high (first high))
  857.           (when (numberp high) (decf high))
  858.         )
  859.         (when (and (numberp low) (numberp high) (not (<= low high))) ; type leer?
  860.           (setq low 0 high 0)
  861.         )
  862.         (yes)
  863.       )
  864.       (unknown)
  865. ) ) )
  866.  
  867. #| Zu tun:
  868. SUBTYPEP so verbessern, daß
  869. (let ((l '(ARRAY BIT-VECTOR CHARACTER COMPLEX CONS FLOAT FUNCTION HASH-TABLE
  870.            INTEGER LIST NULL NUMBER PACKAGE PATHNAME
  871.            #+LOGICAL-PATHNAMES LOGICAL-PATHNAME RANDOM-STATE RATIONAL READTABLE
  872.            REAL SEQUENCE CLOS:STANDARD-GENERIC-FUNCTION STREAM STRING SYMBOL
  873.            VECTOR
  874.      ))   )
  875.   (dolist (a l)
  876.     (dolist (b l)
  877.       (unless (or (subtypep a b) (subtypep b a))
  878.         (unless (equal (multiple-value-list (subtypep `(AND ,a ,b) 'NIL))
  879.                        '(nil t)
  880.                 )
  881.           (print (list a b))
  882. ) ) ) ) )
  883. möglichst wenig ausgibt.
  884. |#
  885.  
  886.