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 ;;----------------------------------------------------------------------
  21 ;; The below functions added by SDB in Sept 2003 to support command-line flag
  22 ;; processing.
  23 ;;----------------------------------------------------------------------
  24
  25 ;;---------------------------------------------------------------
  26 ;;  debug-spew
  27 ;;  Wrapper which spews debug messages if -v flag is set, otherwise
  28 ;;  does nothing.
  29 ;;  Calling form:  (debug-spew "verbose debug text")
  30 ;;--------------------------------------------------------------
  31 (define debug-spew
  32   (lambda (debug-string)
  33     (if (calling-flag? "verbose_mode" (gnetlist:get-calling-flags))
  34         (display debug-string)
  35 )))
  36
  37
  38 ;;---------------------------------------------------------------
  39 ;; calling-flag?
  40 ;;   Returns #t or #f depending upon the corresponding flag
  41 ;;   was set in the calling flags given to gnetlist.
  42 ;;   9.7.2003 -- SDB.
  43 ;;---------------------------------------------------------------
  44 (define calling-flag?
  45   (lambda (searched-4-flag calling-flag-list)
  46
  47     (if (null? calling-flag-list)
  48           '#f                                             ;; return #f if null list -- sort_mode not found.
  49           (let* ((calling-pair (car calling-flag-list))   ;; otherwise look for sort_mode in remainder of list.
  50                  (calling-flag (car calling-pair))
  51                  (flag-value (cadr calling-pair))  )
  52
  53             ;; (display (string-append "examining calling-flag = " calling-flag "\n" ))
  54             ;; (display (string-append "flag-value = " (if flag-value "true" "false") "\n" ))
  55
  56             (if (string=? calling-flag searched-4-flag)
  57                 flag-value                                                 ;; return flag-value if sort_mode found
  58                 (calling-flag? searched-4-flag (cdr calling-flag-list))    ;; otherwise recurse until sort_mode is found
  59             )  ;; end if
  60           )  ;; end of let*
  61      )  ;; end of if (null?
  62 ))
  63
  64 ;;-------------  End of SDB's command line flag functions ----------------
  65
  66 ;; Support functions
  67
  68 ;;  This fcn should behave exactly the same as C's strncmp fcn.
  69 ;;  It compares two strings from the start up to a user-defined end
  70 ;;  char count.  It also checks that the string compare was successful through
  71 ;;  the end char count (i.e. that both strings are >= "end").  This
  72 ;;  guards against returning #t when comparing "unconnected_pin-23" to "unc"
  73 ;;  (over 15 chars).
  74 ;;  I needed to write this because substring chokes when the string arg is
  75 ;;  shorter than the end arg.
  76 ;;  1.4.2006 -- SDB.
  77 (define strncmp?
  78   (lambda (string1 string2 end)
  79     (and
  80      (string-ci=? (substring string1 0 (min end (string-length string1)))
  81                   (substring string2 0 (min end (string-length string2))))
  82      (>= (min (string-length string1) (string-length string2)) end)
  83     )
  84   )
  85 )
  86
  87
  88 ;;  This fcn returns the first len characters of the string str.  If
  89 ;;  str has less than len characters, it returns the whole string
  90 ;;  (but doesn't choke)
  91 (define safe-string-head
  92   (lambda (str len)
  93     (substring str 0 (min len (string-length str)))
  94   )
  95 )
  96
  97 ;;
  98 ;; Given a uref, returns the device attribute value (unknown if not defined)
  99 ;;
 100 (define get-device
 101    (lambda (package)
 102       (gnetlist:get-package-attribute package "device")))
 103
 104 ;; Shorthand for get component values
 105 (define get-value
 106    (lambda (package)
 107       (gnetlist:get-package-attribute package "value")))
 108
 109 (define get-component-text
 110    (lambda (package)
 111       (let ((value (gnetlist:get-package-attribute package "value"))
 112             (label (gnetlist:get-package-attribute package "label"))
 113             (device (gnetlist:get-package-attribute package "device")))
 114          (if (not (string=? "unknown" value))
 115             value
 116             (if (not (string=? "unknown" label))
 117                label
 118                device)))))
 119
 120
 121 ;; return all pins for a particular package
 122 (define pins
 123    (lambda (package)
 124       (gnetlist:get-pins package)))
 125
 126 ;; this is really crude, but I'm tired... :)
 127 (define display-nl
 128    (lambda (list)
 129       (display list)
 130       (newline)))
 131
 132
 133 ;; ah.. wonder what use this is...
 134 (define display-pin
 135    (lambda (pin-list)
 136       (for-each display-nl pin-list)))
 137
 138
 139 ;; ha. I'm playing with scheme here.. don't mind me
 140 (define display-all-pins
 141    (lambda ()
 142       (for-each display-pin all-pins)))
 143
 144
 145 ;; another misc function
 146 (define print-packages
 147    (lambda (plist)
 148       (for-each display-nl plist)))
 149
 150 ;; ETTUS
 151 ;; find-device
 152 ;; Usage:  (find-device packages devicename)
 153 ;; Returns the first package which matches the devicename
 154 (define find-device
 155    (lambda (components devicename)
 156       (if (not (null? components))
 157          (if (string=? devicename (get-device (car components)))
 158             (car components)
 159             (find-device (cdr components) devicename)))))
 160
 161
 162 ;; ETTUS
 163 ;; find-devices
 164 ;; Usage:  (find-devices packages devicename '())
 165 ;; Returns a list of packages which match the device name
 166 (define find-devices
 167    (lambda (components devicename list)
 168       (if (not (null? components))
 169          (if (string=? devicename (get-device (car components)))
 170             (find-devices (cdr components)
 171                                 devicename
 172                                 (cons (car components) list))
 173             (find-devices (cdr components)
 174                                 devicename
 175                                 list))
 176          list)))
 177
 178 ;; ETTUS
 179 ;; contains?
 180 ;; Usage (contains? list item)
 181 ;; True if the list contains the item, according to string=?
 182 (define contains?
 183    (lambda (ls item)
 184       (cond
 185          ((null? ls) #f)
 186          ((string=? item (car ls)) #t)
 187          (#t (contains? (cdr ls) item)))))
 188
 189 ;; ETTUS
 190 ;; Usage: (number-nets all-unique-nets 1)
 191 ;; Returns a list of pairs of form (netname . number)
 192 (define number-nets
 193    (lambda (nets number)
 194       (if (null? nets)
 195          '()
 196          (if (string=? "GND" (car nets))
 197             (cons (cons "GND" 0) (number-nets (cdr nets) number))
 198             (cons
 199                (cons (car nets) number)
 200                (number-nets (cdr nets)(+ number 1)))))))
 201
 202 ;; ETTUS
 203 ;; Usage: (get-net-number netname numberlist)
 204 ;; numberlist should be from (number-nets) above
 205 ;; Returns the number corresponding to the net
 206 (define get-net-number
 207    (lambda (netname numberlist)
 208       (if (not (null? numberlist))
 209          (if (string=? netname (car (car numberlist)))
 210             (cdr (car numberlist))
 211             (get-net-number netname (cdr numberlist))))))
 212
 213 ;;
 214 ;; Useful output functions contributed by Andrew Bardsley
 215 ;;
 216 (define (print-to-port port . l)
 217     (for-each (lambda (elem) (display elem port)) l))
 218
 219 (define (print . l)
 220     (apply print-to-port (cons (current-output-port) l)))
 221
 222 ;;
 223 ;; Wrap a string into lines no longer than wrap-length
 224 ;; wrap-char is put on the end-of-the-wrapped-line, before the return
 225 ;; (from Stefan Petersen)
 226 (define (gnetlist:wrap string-to-wrap wrap-length wrap-char)
 227   (if (> wrap-length (string-length string-to-wrap))
 228       string-to-wrap ; Last snippet of string
 229       (let ((pos (string-rindex string-to-wrap #\space 0 wrap-length)))
 230         (cond ((not pos)
 231                (display "Couldn't wrap string  at requested position\n")
 232                " Wrap error!")
 233               (else
 234                (string-append
 235                 (substring string-to-wrap 0 pos)
 236                 wrap-char
 237                 "\n "
 238                 (gnetlist:wrap (substring string-to-wrap (+ pos 1)) wrap-length wrap-char)))))))
 239
 240 ;; example use
 241 ; (define (run-test test-string wrap-len)
 242 ;   (display (string-append "Wrapping \"" test-string "\" into "))
 243 ;   (display wrap-len)
 244 ;   (newline)
 245 ;   (display (gnetlist:wrap test-string wrap-len " \\"))
 246 ;   (newline)
 247 ;   (newline))
 248
 249 ; (run-test "one two three four five six seven eight nine ten" 5)
 250 ; (run-test "one two three four five six seven eight nine ten" 10)
 251 ; (run-test "one two three four five six seven eight nine ten" 20)
 252
 253 ;; determine the uref to use for a particular OBJECT
 254 (define (gnetlist:get-uref object)
 255   ; Returns first value of first attrib found with given name, or #f.
 256   (define (attrib-first-value object name)
 257     (let ((attrib-lst (get-attrib-value-by-attrib-name object name)))
 258       (if (null? attrib-lst) #f (car attrib-lst))))
 259   ; Handler if we find uref=
 260   (define (handle-uref value)
 261     (simple-format (current-output-port)
 262                    "WARNING: Found uref=~A" value)
 263     (newline)
 264     (simple-format (current-output-port)
 265                    "uref= is deprecated, please use refdes=~A" value)
 266     (newline)
 267     value)
 268
 269   ; Actually find attribute: check refdes, then uref, then return #f.
 270   (cond
 271    ((attrib-first-value object "refdes") => (lambda (x) x))
 272    ((attrib-first-value object "uref") => handle-uref)
 273    (else #f)))
 274
 275 ;; define the default handler for get-uref
 276 (define get-uref gnetlist:get-uref)