| blob | 7b059bbf11b5da533016a9c749f766a1b5cc492b |
1 ;;; gEDA - GPL Electronic Design Automation
2 ;;; gnetlist - gEDA Netlist
3 ;;; Copyright (C) 1998-2010 Ales Hvezda
4 ;;; Copyright (C) 1998-2010 gEDA Contributors (see ChangeLog for details)
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,
19 ;;; MA 02111-1301 USA.
21 (use-modules (srfi srfi-1))
22 (use-modules (geda deprecated))
24 ;;----------------------------------------------------------------------
25 ;; The below functions added by SDB in Sept 2003 to support command-line flag
26 ;; processing.
27 ;;----------------------------------------------------------------------
29 ;;---------------------------------------------------------------
30 ;; debug-spew
31 ;; Wrapper which spews debug messages if -v flag is set, otherwise
32 ;; does nothing.
33 ;; Calling form: (debug-spew "verbose debug text")
34 ;;--------------------------------------------------------------
35 (define debug-spew
36 (lambda (debug-string)
37 (if (= 1 (gnetlist:get-verbosity))
38 (display debug-string)
39 )))
42 (define (gnetlist:get-calling-flags) ; DEPRECATED
43 "Returns a list of `-O' arguments in the form:
45 ((ARGUMENT #t) ...)
47 This function is deprecated, and should not be used in new code. New
48 code should use `gnetlist:get-backend-arguments' directly."
49 (map (lambda (x) (list x #t)) (gnetlist:get-backend-arguments)))
51 ;;---------------------------------------------------------------
52 ;; calling-flag?
53 ;; Returns #t or #f depending upon the corresponding flag
54 ;; was set in the calling flags given to gnetlist.
55 ;; 9.7.2003 -- SDB.
56 ;;---------------------------------------------------------------
57 (define calling-flag?
58 (lambda (searched-4-flag calling-flag-list)
60 (if (null? calling-flag-list)
61 '#f ;; return #f if null list -- sort_mode not found.
62 (let* ((calling-pair (car calling-flag-list)) ;; otherwise look for sort_mode in remainder of list.
63 (calling-flag (car calling-pair))
64 (flag-value (cadr calling-pair)) )
66 ;; (display (string-append "examining calling-flag = " calling-flag "\n" ))
67 ;; (display (string-append "flag-value = " (if flag-value "true" "false") "\n" ))
69 (if (string=? calling-flag searched-4-flag)
70 flag-value ;; return flag-value if sort_mode found
71 (calling-flag? searched-4-flag (cdr calling-flag-list)) ;; otherwise recurse until sort_mode is found
72 ) ;; end if
73 ) ;; end of let*
74 ) ;; end of if (null?
75 ))
77 ;;------------- End of SDB's command line flag functions ----------------
79 ;; Support functions
81 ;; This fcn should behave exactly the same as C's strncmp fcn.
82 ;; It compares two strings from the start up to a user-defined end
83 ;; char count. It also checks that the string compare was successful through
84 ;; the end char count (i.e. that both strings are >= "end"). This
85 ;; guards against returning #t when comparing "unconnected_pin-23" to "unc"
86 ;; (over 15 chars).
87 ;; I needed to write this because substring chokes when the string arg is
88 ;; shorter than the end arg.
89 ;; 1.4.2006 -- SDB.
90 (define strncmp?
91 (lambda (string1 string2 end)
92 (and
93 (string-ci=? (substring string1 0 (min end (string-length string1)))
94 (substring string2 0 (min end (string-length string2))))
95 (>= (min (string-length string1) (string-length string2)) end)
96 )
97 )
98 )
101 ;; This fcn returns the first len characters of the string str. If
102 ;; str has less than len characters, it returns the whole string
103 ;; (but doesn't choke)
104 (define safe-string-head
105 (lambda (str len)
106 (substring str 0 (min len (string-length str)))
107 )
108 )
110 ;; Default resolver: returns value associated with first symbol instance
111 ;; in file order and warns if instances have different values.
112 (define (unique-attribute refdes name values)
113 (let ((value (car values)))
114 (or (every (lambda (x) (equal? x value)) values)
115 (format (current-error-port) "\
116 Possible attribute conflict for refdes: ~A
117 name: ~A
118 values: ~A
119 " refdes name values))
120 value))
122 (define (gnetlist:get-package-attribute refdes name)
123 "Return the value associated with attribute NAME on package
124 identified by REFDES.
126 It actually computes a single value from the full list of values
127 produced by 'gnetlist:get-all-package-attributes' as that list is
128 passed through 'unique-attribute'.
130 For backward compatibility, the default behavior is to return the
131 value associated with the first symbol instance for REFDES. If all
132 instances of REFDES do not have the same value for NAME, it prints a
133 warning.
135 This can be modified by redefining 'unique-attribute' that is a
136 procedure that gets provided a non-empty list of attribute values, the
137 REFDES and the NAME used for the search. It is expected to return a
138 single value as a string or #f for an empty or non-existent attribute
139 value.
141 Note that given the current load sequence of gnetlist, this
142 customization can only happen in the backend itself or in a file
143 loaded after the backend ('-m' option of gnetlist)."
144 (let* ((values (gnetlist:get-all-package-attributes refdes name))
145 (value (and (not (null? values))
146 (unique-attribute refdes name values))))
147 (or value "unknown")))
149 (define (gnetlist:get-slots refdes)
150 "Return a sorted list of slots used by package REFDES.
152 It collects the slot attribute values of each symbol instance of
153 REFDES. As a result, slots may be repeated in the returned list."
154 (sort-list!
155 (filter-map
156 (lambda (slot)
157 (if slot
158 ;; convert string attribute value to number
159 (or (string->number slot)
160 ;; conversion failed, invalid slot, ignore value
161 (begin
162 (format (current-error-port)
163 "Uref ~a: Bad slot number: ~a.\n" refdes slot)
164 #f))
165 ;; no slot attribute, assume slot number is 1
166 1))
167 (gnetlist:get-all-package-attributes refdes "slot"))
168 <))
170 (define (gnetlist:get-unique-slots refdes)
171 "Return a sorted list of unique slots used by package REFDES."
172 (delete-duplicates! (gnetlist:get-slots refdes)))
174 ;;
175 ;; Given a uref, returns the device attribute value (unknown if not defined)
176 ;;
177 (define get-device
178 (lambda (package)
179 (gnetlist:get-package-attribute package "device")))
181 ;; Shorthand for get component values
182 (define get-value
183 (lambda (package)
184 (gnetlist:get-package-attribute package "value")))
186 (define get-component-text
187 (lambda (package)
188 (let ((value (gnetlist:get-package-attribute package "value"))
189 (label (gnetlist:get-package-attribute package "label"))
190 (device (gnetlist:get-package-attribute package "device")))
191 (if (not (string=? "unknown" value))
192 value
193 (if (not (string=? "unknown" label))
194 label
195 device)))))
198 ;; return all pins for a particular package
199 (define pins
200 (lambda (package)
201 (gnetlist:get-pins package)))
203 ;; this is really crude, but I'm tired... :)
204 (define display-nl
205 (lambda (list)
206 (display list)
207 (newline)))
210 ;; ah.. wonder what use this is...
211 (define display-pin
212 (lambda (pin-list)
213 (for-each display-nl pin-list)))
216 ;; ha. I'm playing with scheme here.. don't mind me
217 (define display-all-pins
218 (lambda ()
219 (for-each display-pin all-pins)))
222 ;; another misc function
223 (define print-packages
224 (lambda (plist)
225 (for-each display-nl plist)))
227 ;; ETTUS
228 ;; find-device
229 ;; Usage: (find-device packages devicename)
230 ;; Returns the first package which matches the devicename
231 (define find-device
232 (lambda (components devicename)
233 (if (not (null? components))
234 (if (string=? devicename (get-device (car components)))
235 (car components)
236 (find-device (cdr components) devicename)))))
239 ;; ETTUS
240 ;; find-devices
241 ;; Usage: (find-devices packages devicename '())
242 ;; Returns a list of packages which match the device name
243 (define find-devices
244 (lambda (components devicename list)
245 (if (not (null? components))
246 (if (string=? devicename (get-device (car components)))
247 (find-devices (cdr components)
248 devicename
249 (cons (car components) list))
250 (find-devices (cdr components)
251 devicename
252 list))
253 list)))
255 ;; ETTUS
256 ;; contains?
257 ;; Usage (contains? list item)
258 ;; True if the list contains the item, according to string=?
259 (define contains?
260 (lambda (ls item)
261 (cond
262 ((null? ls) #f)
263 ((string=? item (car ls)) #t)
264 (#t (contains? (cdr ls) item)))))
266 ;; ETTUS
267 ;; Usage: (number-nets all-unique-nets 1)
268 ;; Returns a list of pairs of form (netname . number)
269 (define (number-nets nets number)
270 (define (number-nets-impl in i out)
271 (if (null? in)
272 (reverse! out) ; Return value
273 (let ((netname (car in)))
274 (if (string=? "GND" netname)
275 (number-nets-impl (cdr in) i (cons (cons netname 0) out))
276 (number-nets-impl (cdr in) (1+ i) (cons (cons netname i) out))))))
277 (number-nets-impl nets number '()))
279 ;; ETTUS
280 ;; Usage: (get-net-number netname numberlist)
281 ;; numberlist should be from (number-nets) above
282 ;; Returns the number corresponding to the net
283 (define get-net-number
284 (lambda (netname numberlist)
285 (if (not (null? numberlist))
286 (if (string=? netname (car (car numberlist)))
287 (cdr (car numberlist))
288 (get-net-number netname (cdr numberlist))))))
290 ;;
291 ;; Useful output functions contributed by Andrew Bardsley
292 ;;
293 (define (print-to-port port . l)
294 (for-each (lambda (elem) (display elem port)) l))
296 (define (print . l)
297 (apply print-to-port (cons (current-output-port) l)))
299 ;;
300 ;; Wrap a string into lines no longer than wrap-length
301 ;; wrap-char is put on the end-of-the-wrapped-line, before the return
302 ;; (from Stefan Petersen)
303 (define (gnetlist:wrap string-to-wrap wrap-length wrap-char)
304 (if (> wrap-length (string-length string-to-wrap))
305 string-to-wrap ; Last snippet of string
306 (let ((pos (string-rindex string-to-wrap #\space 0 wrap-length)))
307 (cond ((not pos)
308 (display "Couldn't wrap string at requested position\n")
309 " Wrap error!")
310 (else
311 (string-append
312 (substring string-to-wrap 0 pos)
313 wrap-char
314 "\n "
315 (gnetlist:wrap (substring string-to-wrap (+ pos 1)) wrap-length wrap-char)))))))
317 ;; example use
318 ; (define (run-test test-string wrap-len)
319 ; (display (string-append "Wrapping \"" test-string "\" into "))
320 ; (display wrap-len)
321 ; (newline)
322 ; (display (gnetlist:wrap test-string wrap-len " \\"))
323 ; (newline)
324 ; (newline))
326 ; (run-test "one two three four five six seven eight nine ten" 5)
327 ; (run-test "one two three four five six seven eight nine ten" 10)
328 ; (run-test "one two three four five six seven eight nine ten" 20)
330 ;; determine the uref to use for a particular OBJECT
331 (define (gnetlist:get-uref object)
332 ; Returns first value of first attrib found with given name, or #f.
333 (define (attrib-first-value object name)
334 (let ((attrib-lst (get-attrib-value-by-attrib-name object name)))
335 (if (null? attrib-lst) #f (car attrib-lst))))
336 ; Handler if we find uref=
337 (define (handle-uref value)
338 (simple-format (current-output-port)
339 "WARNING: Found uref=~A" value)
340 (newline)
341 (simple-format (current-output-port)
342 "uref= is deprecated, please use refdes=~A" value)
343 (newline)
344 value)
346 ; Actually find attribute: check refdes, then uref, then return #f.
347 (cond
348 ((attrib-first-value object "refdes") => (lambda (x) x))
349 ((attrib-first-value object "uref") => handle-uref)
350 (else #f)))
352 ;; define the default handler for get-uref
353 (define get-uref gnetlist:get-uref)
355 (define (gnetlist:get-command-line)
356 "Return the command line used to invoke the program."
357 (string-join (program-arguments)))