/[cmucl]/src/pcl/defs.lisp
ViewVC logotype

Diff of /src/pcl/defs.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.3 by ram, Tue Nov 27 15:44:30 1990 UTC revision 1.4 by ram, Sat Oct 19 17:22:16 1991 UTC
# Line 152  Line 152 
152    
153  #-cmu  #-cmu
154  (defun setfboundp (symbol)  (defun setfboundp (symbol)
155    #+Genera nil    #+Genera (not (null (get-properties (symbol-plist symbol)
156                                          'lt::(derived-setf-function trivial-setf-method
157                                                setf-equivalence setf-method))))
158    #+Lucid  (locally    #+Lucid  (locally
159               (declare (special lucid::*setf-inverse-table*               (declare (special lucid::*setf-inverse-table*
160                                 lucid::*simple-setf-method-table*                                 lucid::*simple-setf-method-table*
# Line 305  Line 307 
307      (name (fdefine-carefully (get-setf-function-name name) new-value))))      (name (fdefine-carefully (get-setf-function-name name) new-value))))
308    
309    
310    (defun type-class (type)
311      (if (consp type)
312          (case (car type)
313            (class-eq (cadr type))
314            (eql (class-of (cadr type)))
315            (t (and (null (cdr type)) (find-class (car type) nil))))
316          (if (symbolp type)
317              (find-class type nil)
318              (and (class-specializer-p type)
319                   (specializer-class type)))))
320    
321    (defun class-type-p (type)
322      (if (consp type)
323          (and (null (cdr type)) (find-class (car type) nil))
324          (if (symbolp type)
325              (find-class type nil)
326              (and (classp type) type))))
327    ;;;;;;
328    (defun exact-class-type-p (type)
329      (if (consp type)
330          (or (eq (car type) 'class-eq) (eq (car type) 'eql))
331          (exact-class-specializer-p type)))
332    
333    (defun make-class-eq-predicate (class)
334      (when (symbolp class) (setq class (find-class class)))
335      #'(lambda (object) (eq class (class-of object))))
336    
337    (deftype class-eq (class)
338      `(satisfies ,(make-class-eq-predicate class)))
339    
340    (defun class-eq-type-p (type)
341      (if (consp type)
342          (eq (car type) 'class-eq)
343          (class-eq-specializer-p type)))
344    ;;;;;;
345    (defun make-eql-predicate (eql-object)
346      #'(lambda (object) (eql eql-object object)))
347    
348    (deftype eql (type-object)
349      `(satisfies ,(make-eql-predicate type-object)))
350    
351    (defun eql-type-p (type)
352      (if (consp type)
353          (eq (car type) 'eql)
354          (eql-specializer-p type)))
355    
356    (defun type-object (type)
357      (if (consp type)
358          (cadr type)
359          (specializer-object type)))
360    
361    ;;;;;;
362    (defun not-type-p (type)
363      (and (consp type) (eq (car type) 'not)))
364    
365    (defun not-type (type)
366      (cadr type))
367    
368  ;;;  ;;;
369  ;;; These functions are a pale imitiation of their namesake.  They accept  ;;; These functions are a pale imitiation of their namesake.  They accept
370  ;;; class objects or types where they should.  ;;; class objects or types where they should.
371  ;;;  ;;;
372  (defun *typep (object type)  (defun *typep (object type)
373    (if (classp type)    (let ((specializer (or (class-type-p type)
374        (let ((class (class-of object)))                           (and (specializerp type) type))))
375          (if class      (cond (specializer
376              (memq type (class-precedence-list class))              (specializer-type-p object specializer))
377              nil))            ((not-type-p type)
378        (let ((class (find-class type nil)))             (not (*typep object (not-type type))))
379          (if class            (t
380              (*typep object class)             (typep object type)))))
             (typep object type)))))  
381    
382  (defun *subtypep (type1 type2)  (defun *subtypep (type1 type2)
383    (let ((c1 (if (classp type1) type1 (find-class type1 nil)))    (let ((c1 (class-type-p type1))
384          (c2 (if (classp type2) type2 (find-class type2 nil))))          (c2 (class-type-p type2)))
385      (if (and c1 c2)      (cond ((and c1 c2)
386          (memq c2 (class-precedence-list c1))             (values (memq c2 (class-precedence-list c1)) t))
387          (if (or c1 c2)            ((setq c1 (or c1 (specializerp type1)))
388              nil                                 ;This isn't quite right, but...             (specializer-applicable-using-type-p c1 type2))
389              (subtypep type1 type2)))))            ((or (null c2) (classp c2))
390               (subtypep type1 (if c2 (class-name c2) type2))))))
391    
392  (defun do-satisfies-deftype (name predicate)  (defun do-satisfies-deftype (name predicate)
393  #|  #|
# Line 377  Line 437 
437                      *the-class-method*                      *the-class-method*
438                      *the-class-generic-function*                      *the-class-generic-function*
439                      *the-class-standard-class*                      *the-class-standard-class*
440                        *the-class-funcallable-standard-class*
441                      *the-class-standard-method*                      *the-class-standard-method*
442                      *the-class-standard-generic-function*))                      *the-class-standard-generic-function*
443                        *the-class-standard-effective-slot-definition*
444    
445                        *the-eslotd-standard-class-slots*
446                        *the-eslotd-funcallable-standard-class-slots*))
447    
448  (proclaim '(special *the-wrapper-of-t*  (proclaim '(special *the-wrapper-of-t*
449                      *the-wrapper-of-vector* *the-wrapper-of-symbol*                      *the-wrapper-of-vector* *the-wrapper-of-symbol*
# Line 518  Line 583 
583    
584  (defclass specializer (metaobject) ())  (defclass specializer (metaobject) ())
585    
586    (defclass class-specializer (specializer) ())
587    
588  (defclass definition-source-mixin (standard-object)  (defclass definition-source-mixin (standard-object)
589       ((source       ((source
590          :initform (load-truename)          :initform (load-truename)
# Line 540  Line 607 
607  ;;; have the class CLASS in its class precedence list.  ;;; have the class CLASS in its class precedence list.
608  ;;;  ;;;
609  (defclass class (documentation-mixin dependent-update-mixin definition-source-mixin  (defclass class (documentation-mixin dependent-update-mixin definition-source-mixin
610                                       specializer)                                       class-specializer)
611       ((name       ((name
612          :initform nil          :initform nil
613          :initarg  :name          :initarg  :name
# Line 629  Line 696 
696          :accessor slotd-type)          :accessor slotd-type)
697        (documentation        (documentation
698          :initform ""          :initform ""
699          :initarg :documentation)))          :initarg :documentation)
700          (class
701            :initform nil
702            :accessor slotd-class)
703          (instance-index
704            :initform nil
705            :accessor slotd-instance-index)))
706    
707  (defclass standard-direct-slot-definition (standard-slot-definition  (defclass standard-direct-slot-definition (standard-slot-definition
708                                             direct-slot-definition)                                             direct-slot-definition)
# Line 646  Line 719 
719    
720    
721  (defclass eql-specializer (specializer)  (defclass eql-specializer (specializer)
722       ((object :initarg :object :reader eql-specializer-object)))       ((object :initarg :object :reader specializer-object)))
723    
724    
725    
# Line 663  Line 736 
736                   ,@body)                   ,@body)
737                 (,improper-list-handler)))))                 (,improper-list-handler)))))
738    
739  (defun legal-std-documentation-p (x)  
   (if (or (null x) (stringp x))  
       t  
       "a string or NULL"))  
   
 (defun legal-std-lambda-list-p (x)  
   (declare (ignore x))  
   t)  
   
 (defun legal-std-method-function-p (x)  
   (if (functionp x)  
       t  
       "a function"))  
   
 (defun legal-std-qualifiers-p (x)  
   (flet ((improper-list ()  
            (return-from legal-std-qualifiers-p "Is not a proper list.")))  
     (dolist-carefully (q x improper-list)  
       (let ((ok (legal-std-qualifier-p q)))  
         (unless (eq ok t)  
           (return-from legal-std-qualifiers-p  
             (format nil "Contains ~S which ~A" q ok)))))  
     t))  
   
 (defun legal-std-qualifier-p (x)  
   (if (and x (atom x))  
       t  
       "is not a non-null atom"))  
   
 (defun legal-std-slot-name-p (x)  
   (cond ((not (symbolp x)) "is not a symbol and so cannot be bound")  
         ((keywordp x)      "is a keyword and so cannot be bound")  
         ((memq x '(t nil)) "cannot be bound")  
         (t t)))  
   
 (defun legal-std-specializers-p (x)  
   (flet ((improper-list ()  
            (return-from legal-std-specializers-p "Is not a proper list.")))  
     (dolist-carefully (s x improper-list)  
       (let ((ok (legal-std-specializer-p s)))  
         (unless (eq ok t)  
           (return-from legal-std-specializers-p  
             (format nil "Contains ~S which ~A" s ok)))))  
     t))  
   
 (defun legal-std-specializer-p (x)  
   (if (or (classp x)  
           (eql-specializer-p x))  
       t  
       "is neither a class object nor an eql specializer"))  

Legend:
Removed from v.1.3  
changed lines
  Added in v.1.4

  ViewVC Help
Powered by ViewVC 1.1.5