gnetlist/scheme/gnetlist.scm

   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.
  20
  21 (use-modules (srfi srfi-1))
  22 (use-modules (geda deprecated))
  23
  24 ;;----------------------------------------------------------------------
  25 ;; The below functions added by SDB in Sept 2003 to support command-line flag
  26 ;; processing.
  27 ;;----------------------------------------------------------------------
  28
  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 (calling-flag? "verbose_mode" (gnetlist:get-calling-flags))
  38         (display debug-string)
  39 )))
  40
  41
  42 (define (gnetlist:get-calling-flags) ; DEPRECATED
  43   "Returns a list of `-O' arguments in the form:
  44
  45   ((ARGUMENT #t) ...)
  46
  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)))
  50
  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)
  59
  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))  )
  65
  66             ;; (display (string-append "examining calling-flag = " calling-flag "\n" ))
  67             ;; (display (string-append "flag-value = " (if flag-value "true" "false") "\n" ))
  68
  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 ))
  76
  77 ;;-------------  End of SDB's command line flag functions ----------------
  78
  79 ;; Support functions
  80
  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 )
  99
 100
 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 )
 109
 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))
 121
 122 (define (gnetlist:get-package-attribute refdes name)
 123   "Return the value associated with attribute NAME on package
 124 identified by REFDES.
 125
 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'.
 129
 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.
 134
 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.
 140
 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")))
 148
 149 (define (gnetlist:get-slots refdes)
 150   "Return a sorted list of slots used by package REFDES.
 151
 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    <))
 169
 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)))
 173
 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")))
 180
 181 ;; Shorthand for get component values
 182 (define get-value
 183    (lambda (package)
 184       (gnetlist:get-package-attribute package "value")))
 185
 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)))))
 196
 197
 198 ;; return all pins for a particular package
 199 (define pins
 200    (lambda (package)
 201       (gnetlist:get-pins package)))
 202
 203 ;; this is really crude, but I'm tired... :)
 204 (define display-nl
 205    (lambda (list)
 206       (display list)
 207       (newline)))
 208
 209
 210 ;; ah.. wonder what use this is...
 211 (define display-pin
 212    (lambda (pin-list)
 213       (for-each display-nl pin-list)))
 214
 215
 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)))
 220
 221
 222 ;; another misc function
 223 (define print-packages
 224    (lambda (plist)
 225       (for-each display-nl plist)))
 226
 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)))))
 237
 238
 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)))
 254
 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)))))
 265
 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 '()))
 278
 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))))))
 289
 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))
 295
 296 (define (print . l)
 297     (apply print-to-port (cons (current-output-port) l)))
 298
 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)))))))
 316
 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))
 325
 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)
 329
 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)
 345
 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)))
 351
 352 ;; define the default handler for get-uref
 353 (define get-uref gnetlist:get-uref)
 354
 355 (define (gnetlist:get-command-line)
 356   "Return the command line used to invoke the program."
 357   (string-join (program-arguments)))