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