Commit dd2e7673 by Liam M. Healy

New argument to defmobject

Add key argument :initialize-when-making to defmobject, which controls
whether initialization (by calling reinitialize-instance or some other
function) happens when the make-* function defined by this macro is
called. Choices are
  T=yes always
  NIL=no
  :default-T=optional (default T)
  :default-NIL=optional (default NIL)
and the default is T to be consistent with previous behavior.

This is used in the newly defined defmobject 'permutation.
parent 35688357
;; Permutations ;; Permutations
;; Liam Healy, Sun Mar 26 2006 - 11:51 ;; Liam Healy, Sun Mar 26 2006 - 11:51
;; Time-stamp: <2016-12-03 21:03:56CST permutation.lisp> ;; Time-stamp: <2017-01-01 17:20:46EST permutation.lisp>
;; ;;
;; Copyright 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2014, 2016 Liam M. Healy ;; Copyright 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2014, 2016, 2017 Liam M. Healy
;; Distributed under the terms of the GNU General Public License ;; Distributed under the terms of the GNU General Public License
;; ;;
;; This program is free software: you can redistribute it and/or modify ;; This program is free software: you can redistribute it and/or modify
...@@ -31,26 +31,10 @@ ...@@ -31,26 +31,10 @@
"gsl_permutation" "gsl_permutation"
((size :sizet)) ((size :sizet))
"permutation" "permutation"
:initialize-when-making :default-t
:ri-c-return :void
:initialize-suffix "init") :initialize-suffix "init")
;;; Need this because default the method defined by defmobject has c-return = :int.
(defmfun reinitialize-instance ((object permutation) &key)
"gsl_permutation_init"
(((mpointer object) :pointer))
:definition :method
:qualifier :after
:return (object)
:c-return :void
:export nil
:index (reinitialize-instance permutation))
(defun make-permutation (size &optional (initialize t))
;; Define this outside of defmobject in order to add the optional argument.
"Create the GSL object representing a permutation (class PERMUTATION)."
(let ((object (make-instance 'permutation :size size)))
(when initialize (reinitialize-instance object))
object))
(defmethod print-object ((object permutation) stream) (defmethod print-object ((object permutation) stream)
(print-unreadable-object (object stream :type t) (print-unreadable-object (object stream :type t)
(format stream "size ~d contents ~a" (size object) (grid:contents object)))) (format stream "size ~d contents ~a" (size object) (grid:contents object))))
......
;; Definition of GSL objects and ways to use them. ;; Definition of GSL objects and ways to use them.
;; Liam Healy, Sun Dec 3 2006 - 10:21 ;; Liam Healy, Sun Dec 3 2006 - 10:21
;; Time-stamp: <2011-01-11 19:10:48EST mobject.lisp> ;; Time-stamp: <2017-01-01 17:26:26EST mobject.lisp>
;; ;;
;; Copyright 2006, 2007, 2008, 2009, 2011 Liam M. Healy ;; Copyright 2006, 2007, 2008, 2009, 2011, 2017 Liam M. Healy
;; Distributed under the terms of the GNU General Public License ;; Distributed under the terms of the GNU General Public License
;; ;;
;; This program is free software: you can redistribute it and/or modify ;; This program is free software: you can redistribute it and/or modify
...@@ -44,6 +44,9 @@ ...@@ -44,6 +44,9 @@
;;; Key arguments for defmobject: ;;; Key arguments for defmobject:
;;; documentation ;;; documentation
;;; Docstring for the object maker. ;;; Docstring for the object maker.
;;; initialize-when-making
;;; Call to initializer when making:
;;; T=yes, NIL=no, :default-T=optional (default T), :default-NIL=optional (default NIL)
;;; initialize-suffix ;;; initialize-suffix
;;; The string appended to prefix to form GSL function name or a list of ;;; The string appended to prefix to form GSL function name or a list of
;;; such a string and the c-return argument. ;;; such a string and the c-return argument.
...@@ -75,8 +78,9 @@ ...@@ -75,8 +78,9 @@
(defmacro defmobject (defmacro defmobject
(class prefix allocation-args description (class prefix allocation-args description
&key documentation initialize-suffix initialize-name initialize-args &key documentation (initialize-when-making t) initialize-suffix
arglists-function inputs gsl-version allocator allocate-inputs freer initialize-name initialize-args arglists-function inputs
gsl-version allocator allocate-inputs freer
((:callbacks cbinfo)) (export t) ((:callbacks cbinfo)) (export t)
(superclasses (if cbinfo '(callback-included) '(mobject))) (superclasses (if cbinfo '(callback-included) '(mobject)))
singular switch ri-c-return) singular switch ri-c-return)
...@@ -134,7 +138,7 @@ ...@@ -134,7 +138,7 @@
,@(when cbinfo `((record-callbacks-for-class ',class ',cbinfo))) ,@(when cbinfo `((record-callbacks-for-class ',class ',cbinfo)))
,@(when cbinfo (make-mobject-defmcallbacks cbinfo class)) ,@(when cbinfo (make-mobject-defmcallbacks cbinfo class))
,(mobject-maker ,(mobject-maker
maker arglists class cl-alloc-args cl-initialize-args maker arglists class cl-alloc-args initialize-when-making cl-initialize-args
description documentation initialize-args initializerp settingp description documentation initialize-args initializerp settingp
singular cbinfo)) singular cbinfo))
`(progn `(progn
...@@ -215,51 +219,59 @@ ...@@ -215,51 +219,59 @@
:index (reinitialize-instance ,class)))))) :index (reinitialize-instance ,class))))))
(defun mobject-maker (defun mobject-maker
(maker arglists class cl-alloc-args cl-initialize-args (maker arglists class cl-alloc-args initialize-when-making
description documentation initialize-args initializerp settingp cl-initialize-args description documentation initialize-args
singular cbinfo) initializerp settingp singular cbinfo)
"Make the defun form that makes the mobject." "Make the defun form that makes the mobject."
(when cbinfo (when cbinfo
(setf cl-initialize-args (append cl-initialize-args '((scalarsp t))))) (setf cl-initialize-args (append cl-initialize-args '((scalarsp t)))))
(let ((initargs ; arguments that are exclusively for reinitialize-instance (let ((initargs ; arguments that are exclusively for reinitialize-instance
(remove-if (lambda (s) (member s cl-alloc-args)) cl-initialize-args))) (remove-if (lambda (s) (member s cl-alloc-args)) cl-initialize-args)))
`(defun ,maker `(defun ,maker
,(if arglists ,(if arglists
(first arglists) (first arglists)
(singularize (singularize
singular singular
`(,@cl-alloc-args `(,@cl-alloc-args
,@(when initargs ,@(when (or initargs (member initialize-when-making '(:default-t :default-nil)))
(append (append
(list '(&optional)
'&optional (cond
(if (listp (first initargs)) ((eql initialize-when-making :default-t) '((initialize T)))
`(,@(first initargs) ,settingp) ((eql initialize-when-making :default-nil) '((initialize NIL)))
`(,(first initargs) nil ,settingp))) (t nil))
(rest initargs)))))) (when initargs
(if (listp (first initargs))
`((,@(first initargs) ,settingp))
`((,(first initargs) nil ,settingp))))
(rest initargs))))))
,(format ,(format
nil "Create the GSL object representing a ~a (class ~a).~@[~&~a~]" nil "Create the GSL object representing a ~a (class ~a).~@[~&~a~]"
description class documentation) description class documentation)
(let ((object (let ((object
(make-instance (make-instance
',class ',class
,@(when cbinfo `(:cbinfo ',cbinfo)) ,@(when cbinfo `(:cbinfo ',cbinfo))
,@(if arglists ,@(if arglists
(second arglists) (second arglists)
(symbol-keyword-symbol cl-alloc-args singular))))) (symbol-keyword-symbol cl-alloc-args singular)))))
;; There is an initialization step
,@(when initializerp ,@(when initializerp
(if (or initialize-args arglists) ; with arguments (let ((call
(let ((reii (if (or initialize-args arglists) ; with arguments
`(reinitialize-instance (let ((reii
object `(reinitialize-instance
,@(if arglists object
(third arglists) ,@(if arglists
(symbol-keyword-symbol (third arglists)
(arglist-plain-and-categories cl-initialize-args) (symbol-keyword-symbol
singular))))) (arglist-plain-and-categories cl-initialize-args)
(if initargs `((when ,settingp ,reii)) `(,reii))) singular)))))
'((reinitialize-instance object)))) ; without arguments (if initargs `((when ,settingp ,reii)) `(,reii)))
'((reinitialize-instance object))))) ; without arguments
(case initialize-when-making
((:default-t :default-nil) `((when initialize ,@call)))
((t) call)
(otherwise nil))))
object)))) object))))
(defun plural-symbol (symbol) (defun plural-symbol (symbol)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment