gnetlist/scheme/gnet-bom2.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 ;; --------------------------------------------------------------------------
  22 ;;
  23 ;; Bill of Material backend written by Matt Ettus starts here
  24 ;;
  25
  26 ;;; Bill Of Materials Generator
  27 ;;; You must have a file called attribs in the pwd
  28 ;;; The file should be a text list of attributes you want listed,
  29 ;;; One per line.  No comments are allowed in the file.
  30 ;;; Questions? Contact matt@ettus.com
  31 ;;; This software is released under the terms of the GNU GPL
  32
  33 (use-modules (ice-9 rdelim) ;; guile-1.8 fix
  34              (gnetlist backend-getopt))
  35
  36 (define bom2:open-input-file
  37   (lambda (options)
  38     (let ((filename (backend-option-ref options 'attrib_file "attribs")))
  39       (if (file-exists? filename)
  40           (open-input-file filename)
  41           (if (backend-option-ref options 'attribs) #f
  42               (begin
  43                 (display (string-append "ERROR: Attribute file '" filename "' not found. You must do one of the following:\n"))
  44                 (display "         - Create an 'attribs' file\n")
  45                 (display "         - Specify an attribute file using -Oattrib_file=<filename>\n")
  46                 (display "         - Specify which attributes to include using -Oattribs=attrib1,attrib2,... (no spaces)\n")
  47                 #f))))))
  48
  49 (define bom2
  50   (lambda (output-filename)
  51     (let* ((options (backend-getopt
  52                      (gnetlist:get-backend-arguments)
  53                      '((attrib_file (value #t)) (attribs (value #t)))))
  54            (port (if (string=? "-" output-filename)
  55                      (current-output-port)
  56                      (open-output-file output-filename)))
  57            (attriblist (bom2:parseconfig (bom2:open-input-file options) options)))
  58       (and attriblist
  59            (begin
  60              (bom2:printlist (append (cons 'refdes attriblist) (list "qty")) port #\:)
  61              (newline port)
  62              (bom2:printbom port (bom2:components packages attriblist) 0)
  63              (close-output-port port))))))
  64
  65 (define bom2:printbom
  66   (lambda (port bomlist count)
  67     (if (not (null? bomlist))
  68       (if (not (null? (caar bomlist)))
  69         (begin
  70           (display (caaar bomlist) port)
  71           (if (not (null? (cdaar bomlist)))
  72             (write-char #\, port))
  73           (bom2:printbom port (cons (cons (cdaar bomlist)(cdar bomlist))(cdr bomlist)) (+ count 1))
  74         )
  75         (begin
  76           (display #\: port)
  77           (bom2:printlist (cdar bomlist) port #\:)
  78           (display #\: port)
  79           (display count port)
  80           (newline port)
  81           (bom2:printbom port (cdr bomlist) 0)
  82         )))))
  83
  84 (define bom2:printlist
  85   (lambda (ls port delimiter)
  86     (if (null? ls)
  87         #f
  88         (begin
  89           (display (car ls) port)
  90           (if (not (null? (cdr ls)))
  91             (write-char delimiter port))
  92           (bom2:printlist (cdr ls) port delimiter)))))
  93
  94 ; Parses attrib file. Returns a list of read attributes.
  95 (define bom2:parseconfig
  96   (lambda (port options)
  97     (let ((attribs (backend-option-ref options 'attribs)))
  98       (if attribs (string-split attribs #\,)
  99           (and port
 100                (let ((read-from-file (read-delimited " \n\t" port)))
 101                  (cond ((eof-object? read-from-file)
 102                         '())
 103                        ((= 0 (string-length read-from-file))
 104                         (bom2:parseconfig port options))
 105                        (else
 106                         (cons read-from-file (bom2:parseconfig port options))))))))))
 107
 108 (define bom2:match-list?
 109   (lambda (l1 l2)
 110     (cond
 111       ((and (null? l1)(null? l2))#t)
 112       ((null? l1) #f)
 113       ((null? l2) #f)
 114       ((not (string=? (car l1)(car l2)))#f)
 115       (#t (bom2:match-list? (cdr l1)(cdr l2))))))
 116
 117 (define bom2:match?
 118   (lambda (uref attriblist bomlist)
 119     (if (null? bomlist)
 120       (list (cons (list uref) attriblist))
 121       (if (bom2:match-list? attriblist (cdar bomlist))
 122 ;;        (cons (cons (cons uref (caar bomlist)) (cdar bomlist))(cdr bomlist))
 123         (cons (cons (merge (list uref) (caar bomlist) string<? ) (cdar bomlist))(cdr bomlist))
 124         (cons (car bomlist)(bom2:match? uref attriblist (cdr bomlist)))))))
 125
 126 (define (bom2:in-bom? package)
 127   (string=? "unknown"
 128             (gnetlist:get-package-attribute package "nobom")))
 129
 130 (define (bom2:components-impl ls attriblist bomlist)
 131   (if (null? ls)
 132       (reverse bomlist)
 133       (let* ((package (car ls))
 134              (attribs (bom2:find-attribs package attriblist)))
 135         (bom2:components-impl (cdr ls) attriblist
 136                               (if (bom2:in-bom? package)
 137                                   (bom2:match? package attribs bomlist)
 138                                   bomlist)))))
 139
 140 (define (bom2:components ls attriblist)
 141    (bom2:components-impl ls attriblist '()))
 142
 143 (define bom2:find-attribs
 144   (lambda (package attriblist)
 145     (if (null? attriblist)
 146         '()
 147         (cons (gnetlist:get-package-attribute package (car attriblist))
 148               (bom2:find-attribs package (cdr attriblist))))))
 149
 150 ;;
 151 ;; Bill of Material backend written by Matt Ettus ends here
 152 ;;
 153 ;; --------------------------------------------------------------------------
 154