/[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.1 by wlott, Sun Aug 12 03:46:21 1990 UTC revision 1.1.1.1 by ram, Sat Oct 19 16:44:34 1991 UTC
# Line 146  Line 146 
146        )))        )))
147    
148  (defun setfboundp (symbol)  (defun setfboundp (symbol)
149    #+Genera nil    #+Genera (not (null (get-properties (symbol-plist symbol)
150                                          'lt::(derived-setf-function trivial-setf-method
151                                                setf-equivalence setf-method))))
152    #+Lucid  (locally    #+Lucid  (locally
153               (declare (special lucid::*setf-inverse-table*               (declare (special lucid::*setf-inverse-table*
154                                 lucid::*simple-setf-method-table*                                 lucid::*simple-setf-method-table*
# Line 282  Line 284 
284      (name (fdefine-carefully (get-setf-function-name name) new-value))))      (name (fdefine-carefully (get-setf-function-name name) new-value))))
285    
286    
287    (defun type-class (type)
288      (if (consp type)
289          (case (car type)
290            (class-eq (cadr type))
291            (eql (class-of (cadr type)))
292            (t (and (null (cdr type)) (find-class (car type) nil))))
293          (if (symbolp type)
294              (find-class type nil)
295              (and (class-specializer-p type)
296                   (specializer-class type)))))
297    
298    (defun class-type-p (type)
299      (if (consp type)
300          (and (null (cdr type)) (find-class (car type) nil))
301          (if (symbolp type)
302              (find-class type nil)
303              (and (classp type) type))))
304    ;;;;;;
305    (defun exact-class-type-p (type)
306      (if (consp type)
307          (or (eq (car type) 'class-eq) (eq (car type) 'eql))
308          (exact-class-specializer-p type)))
309    
310    (defun make-class-eq-predicate (class)
311      (when (symbolp class) (setq class (find-class class)))
312      #'(lambda (object) (eq class (class-of object))))
313    
314    (deftype class-eq (class)
315      `(satisfies ,(make-class-eq-predicate class)))
316    
317    (defun class-eq-type-p (type)
318      (if (consp type)
319          (eq (car type) 'class-eq)
320          (class-eq-specializer-p type)))
321    ;;;;;;
322    (defun make-eql-predicate (eql-object)
323      #'(lambda (object) (eql eql-object object)))
324    
325    (deftype eql (type-object)
326      `(satisfies ,(make-eql-predicate type-object)))
327    
328    (defun eql-type-p (type)
329      (if (consp type)
330          (eq (car type) 'eql)
331          (eql-specializer-p type)))
332    
333    (defun type-object (type)
334      (if (consp type)
335          (cadr type)
336          (specializer-object type)))
337    
338    ;;;;;;
339    (defun not-type-p (type)
340      (and (consp type) (eq (car type) 'not)))
341    
342    (defun not-type (type)
343      (cadr type))
344    
345  ;;;  ;;;
346  ;;; These functions are a pale imitiation of their namesake.  They accept  ;;; These functions are a pale imitiation of their namesake.  They accept
347  ;;; class objects or types where they should.  ;;; class objects or types where they should.
348  ;;;  ;;;
349  (defun *typep (object type)  (defun *typep (object type)
350    (if (classp type)    (let ((specializer (or (class-type-p type)
351        (let ((class (class-of object)))                           (and (specializerp type) type))))
352          (if class      (cond (specializer
353              (memq type (class-precedence-list class))              (specializer-type-p object specializer))
354              nil))            ((not-type-p type)
355        (let ((class (find-class type nil)))             (not (*typep object (not-type type))))
356          (if class            (t
357              (*typep object class)             (typep object type)))))
             (typep object type)))))  
358    
359  (defun *subtypep (type1 type2)  (defun *subtypep (type1 type2)
360    (let ((c1 (if (classp type1) type1 (find-class type1 nil)))    (let ((c1 (class-type-p type1))
361          (c2 (if (classp type2) type2 (find-class type2 nil))))          (c2 (class-type-p type2)))
362      (if (and c1 c2)      (cond ((and c1 c2)
363          (memq c2 (class-precedence-list c1))             (values (memq c2 (class-precedence-list c1)) t))
364          (if (or c1 c2)            ((setq c1 (or c1 (specializerp type1)))
365              nil                                 ;This isn't quite right, but...             (specializer-applicable-using-type-p c1 type2))
366              (subtypep type1 type2)))))            ((or (null c2) (classp c2))
367               (subtypep type1 (if c2 (class-name c2) type2))))))
368    
369  (defun do-satisfies-deftype (name predicate)  (defun do-satisfies-deftype (name predicate)
370    (let* ((specifier `(satisfies ,predicate))    (let* ((specifier `(satisfies ,predicate))
# Line 352  Line 412 
412                      *the-class-method*                      *the-class-method*
413                      *the-class-generic-function*                      *the-class-generic-function*
414                      *the-class-standard-class*                      *the-class-standard-class*
415                        *the-class-funcallable-standard-class*
416                      *the-class-standard-method*                      *the-class-standard-method*
417                      *the-class-standard-generic-function*))                      *the-class-standard-generic-function*
418                        *the-class-standard-effective-slot-definition*
419    
420                        *the-eslotd-standard-class-slots*
421                        *the-eslotd-funcallable-standard-class-slots*))
422    
423  (proclaim '(special *the-wrapper-of-t*  (proclaim '(special *the-wrapper-of-t*
424                      *the-wrapper-of-vector* *the-wrapper-of-symbol*                      *the-wrapper-of-vector* *the-wrapper-of-symbol*
# Line 493  Line 558 
558    
559  (defclass specializer (metaobject) ())  (defclass specializer (metaobject) ())
560    
561    (defclass class-specializer (specializer) ())
562    
563  (defclass definition-source-mixin (standard-object)  (defclass definition-source-mixin (standard-object)
564       ((source       ((source
565          :initform (load-truename)          :initform (load-truename)
# Line 515  Line 582 
582  ;;; have the class CLASS in its class precedence list.  ;;; have the class CLASS in its class precedence list.
583  ;;;  ;;;
584  (defclass class (documentation-mixin dependent-update-mixin definition-source-mixin  (defclass class (documentation-mixin dependent-update-mixin definition-source-mixin
585                                       specializer)                                       class-specializer)
586       ((name       ((name
587          :initform nil          :initform nil
588          :initarg  :name          :initarg  :name
# Line 604  Line 671 
671          :accessor slotd-type)          :accessor slotd-type)
672        (documentation        (documentation
673          :initform ""          :initform ""
674          :initarg :documentation)))          :initarg :documentation)
675          (class
676            :initform nil
677            :accessor slotd-class)
678          (instance-index
679            :initform nil
680            :accessor slotd-instance-index)))
681    
682  (defclass standard-direct-slot-definition (standard-slot-definition  (defclass standard-direct-slot-definition (standard-slot-definition
683                                             direct-slot-definition)                                             direct-slot-definition)
# Line 621  Line 694 
694    
695    
696  (defclass eql-specializer (specializer)  (defclass eql-specializer (specializer)
697       ((object :initarg :object :reader eql-specializer-object)))       ((object :initarg :object :reader specializer-object)))
698    
699    
700    
# Line 638  Line 711 
711                   ,@body)                   ,@body)
712                 (,improper-list-handler)))))                 (,improper-list-handler)))))
713    
714  (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  

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.1.1.1

  ViewVC Help
Powered by ViewVC 1.1.5