-
Notifications
You must be signed in to change notification settings - Fork 3
/
fix-pt-objects.lisp
126 lines (107 loc) · 5.39 KB
/
fix-pt-objects.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FM-PLUGIN-TOOLS; Base: 10 -*-
;;; Copyright (c) 2006-2010, Dr. Edmund Weitz. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :fm-plugin-tools)
(defun fm-fix-pt-constructor1* (&key (val 0) (precision +k-deflt-fixed-precision+))
"A convenience version of FM-FIX-PT-CONSTRUCTOR1."
(fm-fix-pt-constructor1 val precision))
(defmacro with-fix-pt ((ptr number &key (precision '+k-deflt-fixed-precision+)) &body body)
"Executes BODY with PTR bound to a fresh FixPt object
intialized with NUMBER and using the precision PRECISION. The
object is guaranteed to be deleted after the execution of BODY."
(rebinding (number)
`(let (,ptr)
(unwind-protect
(progn
(setq ,ptr (fm-fix-pt-constructor1* :precision ,precision))
(cond ((floatp ,number)
(fm-fix-pt-assign-double ,ptr ,number))
((integerp ,number)
(cond ((<= +k170extn-version+ *fm-version*)
(if (fixnump ,number)
(fm-fix-pt-assign-int ,ptr ,number)
(fm-fix-pt-assign-int64 ,ptr ,number)))
;; NOTE: fm-fix-pt-assign-int64 does not exist before FMP 17
(t
(fm-fix-pt-assign-int ,ptr ,number)))))
,@body)
(when ,ptr
(ignore-errors
(fm-fix-pt-delete ,ptr)))))))
(defclass fix-pt-object (fm-object)
()
(:documentation "A FIX-PT-OBJECT is a Lisp object which is a
proxy for a FileMaker `FixPt' object."))
(defmethod fm-delete ((fix-pt-object fix-pt-object))
"Deletes the FixPt \(C++) object which is proxied by
TEXT-OBJECT."
(fm-fix-pt-delete (pointer fix-pt-object)))
(defun make-fix-pt-object (&key (val 0) (precision +k-deflt-fixed-precision+))
"Creates and returns a FIX-PT-OBJECT representing the number
VAL with precision PRECISION."
(let (ptr)
(handler-bind
((error (lambda (cond)
(declare (ignore cond))
(when ptr
(ignore-errors
(fm-fix-pt-delete ptr))))))
(setq ptr (fm-fix-pt-constructor1* val precision))
(make-instance 'fix-pt-object :pointer ptr))))
(defmethod as-integer ((fix-pt-object fix-pt-object))
"Returns the number represented by FIX-PT-OBJECT as an integer."
(cond ((<= +k170extn-version+ *fm-version*)
(fm-fix-pt-as-long64 (pointer fix-pt-object)))
(t
(fm-fix-pt-as-long (pointer fix-pt-object)))))
(defmethod (setf as-integer) ((new-value integer) (fix-pt-object fix-pt-object) &key)
"Sets the number represented by FIX-PT-OBJECT to NEW-VALUE, a
Lisp integer."
(cond ((<= +k170extn-version+ *fm-version*)
(if (fixnump new-value)
(fm-fix-pt-assign-int (pointer fix-pt-object) new-value)
(fm-fix-pt-assign-int64 (pointer fix-pt-object) new-value)))
(t
(fm-fix-pt-assign-int (pointer fix-pt-object) new-value)))
new-value)
(defmethod as-float ((fix-pt-object fix-pt-object))
"Returns the number represented by FIX-PT-OBJECT as a float."
(fm-fix-pt-as-float (pointer fix-pt-object)))
(defmethod (setf as-float) ((new-value float) (fix-pt-object fix-pt-object) &key)
"Sets the number represented by FIX-PT-OBJECT to NEW-VALUE, a
Lisp float."
(fm-fix-pt-assign-double (pointer fix-pt-object) new-value)
new-value)
(defmethod as-boolean ((fix-pt-object fix-pt-object))
"Returns the number represented by FIX-PT-OBJECT as a boolean."
(fm-fix-pt-as-bool (pointer fix-pt-object)))
(defmethod (setf as-boolean) (new-value (fix-pt-object fix-pt-object) &key)
"Sets the number represented by FIX-PT-OBJECT to \(the
FileMaker equivalent of) NEW-VALUE, a generalized Lisp boolean."
(setf (as-integer fix-pt-object) (if new-value 1 0)))
(defmethod precision ((fix-pt-object fix-pt-object))
"Returns the precision of FIX-PT-OBJECT."
(fm-fix-pt-get-precision (pointer fix-pt-object)))
(defmethod (setf precision) ((new-value integer) (fix-pt-object fix-pt-object))
"Sets the precision of FIX-PT-OBJECT."
(fm-fix-pt-set-precision (pointer fix-pt-object) new-value)
new-value)