/[cmucl]/src/pcl/std-class.lisp
ViewVC logotype

Diff of /src/pcl/std-class.lisp

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

revision 1.32 by pmai, Mon Aug 26 02:23:15 2002 UTC revision 1.33 by pmai, Tue Aug 27 18:46:49 2002 UTC
# Line 374  Line 374 
374                    *the-class-standard-class*)                    *the-class-standard-class*)
375                   (t                   (t
376                    (class-of class)))))                    (class-of class)))))
377      (labels ((program-error (format-control &rest args)      (flet ((fix-super (s)
378                 (error 'kernel:simple-program-error               (cond ((classp s) s)
379                        :format-control format-control                     ((not (legal-class-name-p s))
380                        :format-arguments args))                      (simple-program-error
381               (fix-super (s)                       "~S is not a class or a legal class name." s))
382                 (cond ((classp s) s)                     (t
383                       ((not (legal-class-name-p s))                      (or (find-class s nil)
384                        (program-error "~S is not a class or a legal ~                          (setf (find-class s)
385                                        class name." s))                                (make-instance 'forward-referenced-class
386                       (t                                               :name s)))))))
                       (or (find-class s nil)  
                           (setf (find-class s)  
                                 (make-instance 'forward-referenced-class  
                                                :name s)))))))  
387        ;;        ;;
388        ;; CLHS: signal PROGRAM-ERROR, if        ;; CLHS: signal PROGRAM-ERROR, if
389        ;; (a) there are any duplicate slot names        ;; (a) there are any duplicate slot names
# Line 396  Line 392 
392        (loop for (slot . more) on (getf initargs :direct-slots)        (loop for (slot . more) on (getf initargs :direct-slots)
393              for slot-name = (getf slot :name)              for slot-name = (getf slot :name)
394              if (some (lambda (s) (eq slot-name (getf s :name))) more) do              if (some (lambda (s) (eq slot-name (getf s :name))) more) do
395                (program-error "More than one direct slot with name ~S."                (simple-program-error
396                               slot-name)                 "More than one direct slot with name ~S."
397                   slot-name)
398              else do              else do
399                (loop for (option value . more) on slot by #'cddr                (loop for (option value . more) on slot by #'cddr
400                      when (and (member option '(:allocation :type :initform                      when (and (member option '(:allocation :type :initform
401                                                 :documentation))                                                 :documentation))
402                                (not (eq unsupplied                                (not (eq unsupplied
403                                         (getf more option unsupplied)))) do                                         (getf more option unsupplied)))) do
404                        (program-error "Duplicate slot option ~S for slot ~S."                        (simple-program-error
405                                       option slot-name)))                         "Duplicate slot option ~S for slot ~S."
406                           option slot-name)))
407        ;;        ;;
408        ;; CLHS: signal PROGRAM-ERROR, if an initialization argument name        ;; CLHS: signal PROGRAM-ERROR, if an initialization argument name
409        ;; appears more than once in :DEFAULT-INITARGS class option.        ;; appears more than once in :DEFAULT-INITARGS class option.
410        (loop for (initarg . more) on (getf initargs :direct-default-initargs)        (loop for (initarg . more) on (getf initargs :direct-default-initargs)
411              for name = (car initarg)              for name = (car initarg)
412              when (some (lambda (a) (eq (car a) name)) more) do              when (some (lambda (a) (eq (car a) name)) more) do
413                (program-error "Duplicate initialization argument ~                (simple-program-error
414                                name ~S in :default-initargs of class ~A."                 "Duplicate initialization argument ~
415                               name class))                  name ~S in :default-initargs of class ~A."
416                   name class))
417        ;;        ;;
418        (loop (unless (remf initargs :metaclass) (return)))        (loop (unless (remf initargs :metaclass) (return)))
419        (loop (unless (remf initargs :direct-superclasses) (return)))        (loop (unless (remf initargs :direct-superclasses) (return)))

Legend:
Removed from v.1.32  
changed lines
  Added in v.1.33

  ViewVC Help
Powered by ViewVC 1.1.5