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
;; 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
;;
;; This program is free software: you can redistribute it and/or modify
......@@ -31,26 +31,10 @@
"gsl_permutation"
((size :sizet))
"permutation"
:initialize-when-making :default-t
:ri-c-return :void
: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)
(print-unreadable-object (object stream :type t)
(format stream "size ~d contents ~a" (size object) (grid:contents object))))
......
;; Definition of GSL objects and ways to use them.
;; 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
;;
;; This program is free software: you can redistribute it and/or modify
......@@ -44,6 +44,9 @@
;;; Key arguments for defmobject:
;;; documentation
;;; 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
;;; The string appended to prefix to form GSL function name or a list of
;;; such a string and the c-return argument.
......@@ -75,8 +78,9 @@
(defmacro defmobject
(class prefix allocation-args description
&key documentation initialize-suffix initialize-name initialize-args
arglists-function inputs gsl-version allocator allocate-inputs freer
&key documentation (initialize-when-making t) initialize-suffix
initialize-name initialize-args arglists-function inputs
gsl-version allocator allocate-inputs freer
((:callbacks cbinfo)) (export t)
(superclasses (if cbinfo '(callback-included) '(mobject)))
singular switch ri-c-return)
......@@ -134,7 +138,7 @@
,@(when cbinfo `((record-callbacks-for-class ',class ',cbinfo)))
,@(when cbinfo (make-mobject-defmcallbacks cbinfo class))
,(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
singular cbinfo))
`(progn
......@@ -215,9 +219,9 @@
:index (reinitialize-instance ,class))))))
(defun mobject-maker
(maker arglists class cl-alloc-args cl-initialize-args
description documentation initialize-args initializerp settingp
singular cbinfo)
(maker arglists class cl-alloc-args initialize-when-making
cl-initialize-args description documentation initialize-args
initializerp settingp singular cbinfo)
"Make the defun form that makes the mobject."
(when cbinfo
(setf cl-initialize-args (append cl-initialize-args '((scalarsp t)))))
......@@ -229,13 +233,17 @@
(singularize
singular
`(,@cl-alloc-args
,@(when initargs
,@(when (or initargs (member initialize-when-making '(:default-t :default-nil)))
(append
(list
'&optional
'(&optional)
(cond
((eql initialize-when-making :default-t) '((initialize T)))
((eql initialize-when-making :default-nil) '((initialize NIL)))
(t nil))
(when initargs
(if (listp (first initargs))
`(,@(first initargs) ,settingp)
`(,(first initargs) nil ,settingp)))
`((,@(first initargs) ,settingp))
`((,(first initargs) nil ,settingp))))
(rest initargs))))))
,(format
nil "Create the GSL object representing a ~a (class ~a).~@[~&~a~]"
......@@ -247,8 +255,8 @@
,@(if arglists
(second arglists)
(symbol-keyword-symbol cl-alloc-args singular)))))
;; There is an initialization step
,@(when initializerp
(let ((call
(if (or initialize-args arglists) ; with arguments
(let ((reii
`(reinitialize-instance
......@@ -259,7 +267,11 @@
(arglist-plain-and-categories cl-initialize-args)
singular)))))
(if initargs `((when ,settingp ,reii)) `(,reii)))
'((reinitialize-instance object)))) ; without arguments
'((reinitialize-instance object))))) ; without arguments
(case initialize-when-making
((:default-t :default-nil) `((when initialize ,@call)))
((t) call)
(otherwise nil))))
object))))
(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