1;;; Lepton EDA library - Scheme API
2;;; Copyright (C) 2010-2011 Peter Brett <peter@peter-b.co.uk>
3;;; Copyright (C) 2012-2016 gEDA Contributors
4;;; Copyright (C) 2017-2021 Lepton EDA Contributors
5;;;
6;;; This program is free software; you can redistribute it and/or modify
7;;; it under the terms of the GNU General Public License as published by
8;;; the Free Software Foundation; either version 2 of the License, or
9;;; (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
19
20
21(define-module (lepton object type)
22  #:use-module (system foreign)
23
24  #:use-module (lepton ffi)
25  #:use-module (lepton object foreign)
26
27  #:export (geda-object->pointer*
28
29            arc?
30            attribute?
31            box?
32            bus?
33            circle?
34            component?
35            line?
36            net?
37            path?
38            picture?
39            pin?
40            net-pin?
41            bus-pin?
42            text?
43
44            object?
45            object-type
46            object-type?))
47
48;;; This syntax rule is intended for use in toplevel 'define' or
49;;; 'let' forms in the functions where the check for wrong type of
50;;; OBJECT is necessary.  The rule checks the object and, if it is
51;;; not #<geda-object>, throws an error with the 'wrong-type-arg
52;;; key reporting the function name and position POS of the
53;;; OBJECT argument.  In short, the usage is as follows:
54;;;   (define (myfunc object)
55;;;     (define pointer (geda-object->pointer* object 1))
56;;;     (function-body))
57(define-syntax geda-object->pointer*
58  (syntax-rules ()
59    ((_ object pos)
60     (let ((pointer (geda-object->pointer object)))
61       (if (null-pointer? pointer)
62           (let ((proc-name
63                  (frame-procedure-name (stack-ref (make-stack #t) 1))))
64             (scm-error 'wrong-type-arg
65                        proc-name
66                        "Wrong type argument in position ~A: ~A"
67                        (list pos object)
68                        #f))
69           pointer)))
70    ((_ object pos object-check-func type)
71     (let ((pointer (geda-object->pointer object))
72           (proc-name (frame-procedure-name (stack-ref (make-stack #t) 1))))
73       (if (null-pointer? pointer)
74           (scm-error 'wrong-type-arg
75                      proc-name
76                      "Wrong type argument in position ~A: ~A"
77                      (list pos object)
78                      #f)
79           (if (object-check-func object)
80               pointer
81               (scm-error 'wrong-type-arg
82                          proc-name
83                          "Wrong type argument in position ~A (expecting ~A object): ~A"
84                          (list pos type object)
85                          #f)))))))
86
87
88(define (object? object)
89  "Returns #t if OBJECT is a #<geda-object> instance, otherwise
90returns #f."
91  (geda-object-pointer? (scm->pointer object)))
92
93
94(define (arc? object)
95  "Returns #t if OBJECT is a arc object, otherwise returns #f."
96  (true? (lepton_object_is_arc (geda-object->pointer object))))
97
98(define (box? object)
99  "Returns #t if OBJECT is a box object, otherwise returns #f."
100  (true? (lepton_object_is_box (geda-object->pointer object))))
101
102(define (bus? object)
103  "Returns #t if OBJECT is a bus object, otherwise returns #f."
104  (true? (lepton_object_is_bus (geda-object->pointer object))))
105
106(define (circle? object)
107  "Returns #t if OBJECT is a circle object, otherwise returns #f."
108  (true? (lepton_object_is_circle (geda-object->pointer object))))
109
110(define (component? object)
111  "Returns #t if OBJECT is a component object, otherwise returns #f."
112  (true? (lepton_object_is_component (geda-object->pointer object))))
113
114(define (line? object)
115  "Returns #t if OBJECT is a line object, otherwise returns #f."
116  (true? (lepton_object_is_line (geda-object->pointer object))))
117
118(define-public (net? object)
119  "Returns #t if OBJECT is a net object, otherwise returns #f."
120  (true? (lepton_object_is_net (geda-object->pointer object))))
121
122(define (path? object)
123  "Returns #t if OBJECT is a path object, otherwise returns #f."
124  (true? (lepton_object_is_path (geda-object->pointer object))))
125
126(define (picture? object)
127  "Returns #t if OBJECT is a picture object, otherwise returns #f."
128  (true? (lepton_object_is_picture (geda-object->pointer object))))
129
130(define (pin? object)
131  "Returns #t if OBJECT is a pin object, otherwise returns #f."
132  (true? (lepton_object_is_pin (geda-object->pointer object))))
133
134(define (net-pin? object)
135  "Returns #t if OBJECT is a net pin object, otherwise returns
136#f."
137  (and (pin? object)
138       (true? (lepton_pin_object_is_net_pin
139               (geda-object->pointer object)))))
140
141(define (bus-pin? object)
142  "Returns #t if OBJECT is a bus pin object, otherwise returns
143#f."
144  (and (pin? object)
145       (true? (lepton_pin_object_is_bus_pin
146               (geda-object->pointer object)))))
147
148
149(define (text? object)
150  "Returns #t if OBJECT is a text object, otherwise returns #f."
151  (true? (lepton_object_is_text (geda-object->pointer object))))
152
153(define (attribute? object)
154  "Returns #t if OBJECT is an attribute text object, otherwise
155returns #f."
156  (true? (lepton_object_is_attrib (geda-object->pointer object))))
157
158(define (object-type object)
159  "Returns a Scheme symbol representing the type of OBJECT.  The
160type may be one of the symbols: 'arc, 'box, 'bus, 'circle,
161'complex, 'line, 'net, 'path, 'picture, 'pin, or 'text."
162  (define pointer (geda-object->pointer* object 1))
163
164  (cond
165   ((arc? object) 'arc)
166   ((box? object) 'box)
167   ((bus? object) 'bus)
168   ((circle? object) 'circle)
169   ((component? object) 'complex)
170   ((line? object) 'line)
171   ((net? object) 'net)
172   ((path? object) 'path)
173   ((picture? object) 'picture)
174   ((pin? object) 'pin)
175   ((text? object) 'text)
176   (else (error "Object ~A has bad type '~A'"
177                object
178                (integer->char (lepton_object_get_type pointer))))))
179
180(define (object-type? object type)
181  "Returns #t if OBJECT is a Lepton primitive object and its type
182is TYPE which should be one of the symbols: 'arc, 'box, 'bus,
183'circle, 'complex, 'line, 'net, 'path, 'picture, 'pin, or 'text.
184Otherwise returns #f."
185  (and (object? object)
186       (eq? (object-type object) type)))
187