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