Re: [Gcl-devel] Build failing with --enable-ansi

[Camm Maguire]

Greetings!  What do I return for

(subtypep 1 (find-class 'integer))

?  Why not (values t t)?  (typep 1 (find-class 'integer)) is t.

Take care,

Peter Wood <address@hidden> writes:

> --AqsLC8rIMeq19msA
> Content-Type: text/plain; charset=us-ascii
> Content-Disposition: inline
> 
> On Mon, Jan 13, 2003 at 02:14:43PM -0500, Camm Maguire wrote:
> > Greetings!
> > 
> > Yes, I am referring to your make-specializable 'hack'.  I'd like to
> > know 
> > 
> > 1) Any other changes you had to make (i.e. value stack, changes to
> >    make-specializable, ...
> > 2) What the general aim of this 'hack' is.  I still don't understand
> >    what it is about our current typep, subtypep, and coerce which is
> >    causing test errors.
> > 
> > Obviously, I haven't done my homework, but a quick explanation could
> > really save me some time, in case you have any :-).
> > 
> 
> Hi
> 
> This is a real bad day for my memory!  It was the frame stack I
> increased, and  I don't believe it had anything to do with
> make-specializable.  You probably got the value stack overflow because
> of an error in the build.
> 
> The aim of this hack is to allow typep, subtypep and coerce to take
> arguments which are classes.  This is necessary for ansi compliance,
> since a type-specifier can be a class object (not just the symbol
> naming the class).  In the following examples, when subtypep returns 2
> values, the first one is (not nil) ie, a generalized boolean, ie T.
> It is probably better to return T explicitly as the first value in
> these cases, although this way is allowable.
> 
> Examples:
> > (subtypep (find-class 'integer) (find-class t))
> 
> (#<Built-In-Class T 1045403600>)
> T
> 
> > (defstruct foo bar baz)
> 
> FOO
> 
> > (defstruct (bar (:include foo)))
> 
> BAR
> 
> > (subtypep 'bar (find-class 'foo))
> 
> NIL
> NIL
> > (setf b1 (make-bar))
> 
> #S(BAR BAR NIL BAZ NIL)
> 
> > (typep b1 (find-class 'bar))
> 
> #S(BAR BAR NIL BAZ NIL)
> 
> > (find-class t)
> 
> #<Built-In-Class T 1045403600>
> 
> > (subtypep (find-class 'integer) (find-class t))
> 
> (#<Built-In-Class T 1045403600>)
> T
> 
> See the attached file "genericize.lsp" -- It's gross, but it
> works. (cringe). I only wrote methods to fix specific tests, but the
> nice thing about clos is its sooo easy to add new ones: for example, I
> haven't included a method for checking subtypes of structure-classes
> ... so here is one:
> 
> > (defmethod subtypep ((type-1 structure-class) (type-2 structure-class) 
> > &option
> al (env nil)) (values (member type-2 (pcl::class-precedence-list type-1)) t))
> 
> #<Standard-Method #:SPECIALIZED-SUBTYPEP (STRUCTURE-CLASS
>                                           STRUCTURE-CLASS) 1064562610>
> 
> > (defstruct foo bar baz)
> 
> FOO
> 
> > (defstruct (bar (:include foo)))
> 
> BAR
> 
> > (subtypep (find-class 'bar) (find-class 'foo))
> 
> (#<Structure-Class FOO 1063773300>
>  #<Structure-Class STRUCTURE-OBJECT 1045403740>
>  #<Slot-Class PCL::SLOT-OBJECT 1045403660>
>  #<Built-In-Class T 1045403600>)
> T
> 
> Note: I don't know if this is ansi or not.  It looks sensible to me
> (not necessarily a reccomendation, I know :-)
> 
> For make-specializable, remove the list around the :function
> initializer (see attached diff).
> 
> I don't _think_ (hah!)  I needed to make any other changes.  You need
> to compile genericize.lsp in a seperate image than the one you intend
> to load it into (I think, just like PCL). If you still run into
> problems, mail me the details and I will try to help.
> 
> Regards,
> Peter
> 
> 
> --AqsLC8rIMeq19msA
> Content-Type: text/plain; charset=us-ascii
> Content-Disposition: attachment; filename="methods.lisp.patch"
> 
> Index: pcl/methods.lisp
> ===================================================================
> RCS file: /usr/local/CVS/agcl/pcl/methods.lisp,v
> retrieving revision 1.1
> retrieving revision 1.2
> diff -u -b -B -r1.1 -r1.2
> --- pcl/methods.lisp  2002/11/04 15:59:30     1.1
> +++ pcl/methods.lisp  2002/11/21 20:08:38     1.2
> @@ -442,10 +442,14 @@
>                             ()
>                             (make-list nrequireds :initial-element 't)
>                             arglist
> -                           (list :function
> +;                          (list :function
> +;                                #'(lambda (args next-methods)
> +;                                    (declare (ignore next-methods))
> +;                                    (apply original args)))))
> +                           :function
>                                   #'(lambda (args next-methods)
>                                       (declare (ignore next-methods))
> -                                     (apply original args)))))
> +                                     (apply original args))))))
>         generic-function))))
>  
>  
> 
> --AqsLC8rIMeq19msA
> Content-Type: text/plain; charset=us-ascii
> Content-Disposition: attachment; filename="genericize.lsp"
> 
> ;the following is a _preliminary_ _hack_  ...
> ;which means it will probably look like this in 10 yrs time too
> (eval-when (load)
> 
> (setf (symbol-function 'specialized-coerce) (symbol-function 'coerce))
> 
> (pcl::make-specializable 'specialized-coerce :arglist '(obj typ))
> 
> (defmethod specialized-coerce ((obj t) (type symbol))
>   (call-next-method))
> 
> (setf (symbol-function 'coerce) (symbol-function 'specialized-coerce))
> 
> (defmethod coerce ((obj t) (type symbol))
>   (call-next-method))
>   
> (defmethod coerce ((obj t) (type built-in-class))
>   (if (eq (class-of obj)
>         type)
>       obj
>       (error 'type-error :datum obj
>            :expected-type (type-of obj))))
> 
> (defmethod coerce ((obj t) (type standard-class))
>   (if (eq (class-of obj)
>         type)
>       obj
>       (error 'type-error :datum obj
>            :expected-type (type-of obj))))
>   
> (fmakunbound 'specialized-coerce)
> (unintern 'specialized-coerce)
> 
> (setf (symbol-function 'specialized-typep) (symbol-function 'typep))
> 
> (pcl::make-specializable 'specialized-typep :arglist '(obj type &optional 
> (env nil) &aux tp i tem))
> 
> (setf (symbol-function 'typep) (symbol-function 'specialized-typep))
> 
> (defmethod typep ((obj t) (type built-in-class) &optional (env nil) &aux tp i 
> tem)
>   (when (eq (class-of obj)
>           type)
>     obj))
> 
> (defmethod typep ((obj t) (type standard-class) &optional (env nil) &aux tp i 
> tem)
>   (when (eq (class-of obj)
>           type)
>     obj))
> 
> (defmethod typep ((obj t) (type structure-class) &optional (env nil))
>   (when (eq (class-of obj)
>           type)
>     obj))
> 
> (fmakunbound 'specialized-typep)
> (unintern 'specialized-typep)
> 
> (setf (symbol-function 'specialized-subtypep) (symbol-function 'subtypep))
> 
> (pcl::make-specializable 'specialized-subtypep :arglist '(type1 type2 
> &optional (env nil)))
> 
> (setf (symbol-function 'subtypep) (symbol-function 'specialized-subtypep))
> 
> (defmethod subtypep ((type-1 built-in-class) (type-2 built-in-class) 
> &optional (env nil))
>   (values (member type-2 (pcl::class-precedence-list type-1)) t))
> 
> (defmethod subtypep ((type-1 standard-class) (type-2 standard-class) 
> &optional (env nil))
>   (values (member type-2 (pcl::class-precedence-list type-1)) t))
> 
> (defmethod subtypep ((type-1 standard-class) (type-2 built-in-class) 
> &optional (env nil))
>   (values (member type-2 (pcl::class-precedence-list type-1)) t))
> 
> (defmethod subtypep ((type-1 symbol) (type-2 built-in-class) &optional (env 
> nil))
>   (if (member type-1 '(CONS SYMBOL ARRAY NUMBER CHARACTER HASH-TABLE FUNCTION 
> READTABLE
>                               PACKAGE PATHNAME STREAM RANDOM-STATE CONDITION 
> RESTART))
>       (values nil t)
>       (values nil nil)))
> 
> (defmethod subtypep ((type-1 symbol) (type-2 standard-class) &optional (env 
> nil))
>   (if (member type-1 '(CONS SYMBOL ARRAY NUMBER CHARACTER HASH-TABLE FUNCTION 
> READTABLE
>                               PACKAGE PATHNAME STREAM RANDOM-STATE CONDITION 
> RESTART))
>       (values nil t)
>       (values nil nil)))
> 
> (defmethod subtypep ((type-1 symbol) (type-2 structure-class) &optional (env 
> nil))
>   (if (member type-1 '(CONS SYMBOL ARRAY NUMBER CHARACTER HASH-TABLE FUNCTION 
> READTABLE
>                               PACKAGE PATHNAME STREAM RANDOM-STATE CONDITION 
> RESTART))
>       (values nil t)
>       (values nil nil)))
> 
> (defmethod subtypep ((type-1 structure-class) (type-2 symbol) &optional (env 
> nil))
>   (if (member type-2 '(CONS SYMBOL ARRAY NUMBER CHARACTER HASH-TABLE FUNCTION 
> READTABLE
>                               PACKAGE PATHNAME STREAM RANDOM-STATE CONDITION 
> RESTART))
>       (values nil t)
>       (values nil nil)))
> 
> (defmethod subtypep ((type-1 standard-class) (type-2 symbol) &optional (env 
> nil))
>   (if (member type-2 '(CONS SYMBOL ARRAY NUMBER CHARACTER HASH-TABLE FUNCTION 
> READTABLE
>                               PACKAGE PATHNAME STREAM RANDOM-STATE CONDITION 
> RESTART))
>       (values nil t)
>       (values nil nil)))
> 
> (defmethod subtypep ((type-1 built-in-class) (type-2 symbol) &optional (env 
> nil))
>   (if (member type-2 '(CONS SYMBOL ARRAY NUMBER CHARACTER HASH-TABLE FUNCTION 
> READTABLE
>                               PACKAGE PATHNAME STREAM RANDOM-STATE CONDITION 
> RESTART))
>       (values nil t)
>       (values nil nil)))
> 
> (fmakunbound 'specialized-subtypep)
> (unintern 'specialized-subtypep))
> --AqsLC8rIMeq19msA
> Content-Type: text/plain; charset="us-ascii"
> MIME-Version: 1.0
> Content-Transfer-Encoding: 7bit
> 
> _______________________________________________
> Gcl-devel mailing list
> address@hidden
> http://mail.gnu.org/mailman/listinfo/gcl-devel
> 
> --AqsLC8rIMeq19msA--
> 
> 
> 
> 

-- 
Camm Maguire                                            address@hidden
==========================================================================
"The earth is but one country, and mankind its citizens."  --  Baha'u'llah