gschem/scheme/auto-uref.scm

   1 ;; gEDA - GPL Electronic Design Automation
   2 ;; gschem - gEDA Schematic Capture
   3 ;; Copyright (C) 1998-2007 Ales Hvezda
   4 ;; Copyright (C) 1998-2007 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., 59 Temple Place, Suite 330, Boston, MA 02111 USA
  19
  20 (use-modules (ice-9 regex))
  21
  22 (define prefix-list '())
  23
  24 (define (auto-uref attribs)
  25
  26   (define (get-next-uref prefix)
  27     (let ((available-prefix (assoc prefix prefix-list)))
  28       (cond (available-prefix
  29              (assoc-set! prefix-list
  30                          (car available-prefix)
  31                          (+ (cdr available-prefix) 1))
  32              (cdr available-prefix))
  33             (else ; First time prefix was seen
  34              (set! prefix-list (acons  prefix 1 prefix-list))
  35              1))))
  36
  37
  38   ;; Total Guile
  39   (define (get-prefix value)
  40     (let ((prefix (string-match "^[A-Z]*" value)))
  41       (if (= 0 (match:end prefix))
  42           #f
  43           (match:substring prefix))))
  44
  45
  46   (for-each
  47    (lambda (attrib)
  48      (let* ((name-value (get-attribute-name-value attrib))
  49             (name (car name-value))
  50             (value (cdr name-value))
  51             (prefix (get-prefix value)))
  52        ; If get-prefix fails (returns #f) there is no ? in the string
  53        (if (and prefix (string=? name "refdes"))
  54            (set-attribute-value! attrib (string-append
  55                                          prefix
  56                                          (number->string (get-next-uref prefix)))))))
  57    attribs))