Commit dd2e7673 authored by Liam M. Healy's avatar Liam M. Healy
Browse files

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
Loading
Loading
Loading
Loading
+4 −20
Original line number Diff line number Diff line
;; 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))))
+47 −35
Original line number Diff line number Diff line
;; 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)