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
  35 (define bom2
  36   (lambda (output-filename)
  37     (let ((port (if (string=? "-" output-filename)
  38                       (current-output-port)
  39                       (open-output-file output-filename)))
  40           (attriblist (bom2:parseconfig (open-input-file "attribs"))))
  41       (bom2:printlist (append (cons 'refdes attriblist) (list "qty")) port #\:)
  42       (newline port)
  43       (bom2:printbom port (bom2:components packages attriblist) 0)
  44       (close-output-port port))))
  45
  46 (define bom2:printbom
  47   (lambda (port bomlist count)
  48     (if (not (null? bomlist))
  49       (if (not (null? (caar bomlist)))
  50         (begin
  51           (display (caaar bomlist) port)
  52           (if (not (null? (cdaar bomlist)))
  53             (write-char #\, port))
  54           (bom2:printbom port (cons (cons (cdaar bomlist)(cdar bomlist))(cdr bomlist)) (+ count 1))
  55         )
  56         (begin
  57           (display #\: port)
  58           (bom2:printlist (cdar bomlist) port #\:)
  59           (display #\: port)
  60           (display count port)
  61           (newline port)
  62           (bom2:printbom port (cdr bomlist) 0)
  63         )))))
  64
  65 (define bom2:printlist
  66   (lambda (ls port delimiter)
  67     (if (null? ls)
  68         #f
  69         (begin
  70           (display (car ls) port)
  71           (if (not (null? (cdr ls)))
  72             (write-char delimiter port))
  73           (bom2:printlist (cdr ls) port delimiter)))))
  74
  75 ; Parses attrib file. Returns a list of read attributes.
  76 (define bom2:parseconfig
  77   (lambda (port)
  78     (let ((read-from-file (read-delimited " \n\t" port)))
  79       (cond ((eof-object? read-from-file)
  80              '())
  81             ((= 0 (string-length read-from-file))
  82              (bom2:parseconfig port))
  83             (else
  84              (cons read-from-file (bom2:parseconfig port)))))))
  85
  86 (define bom2:match-list?
  87   (lambda (l1 l2)
  88     (cond
  89       ((and (null? l1)(null? l2))#t)
  90       ((null? l1) #f)
  91       ((null? l2) #f)
  92       ((not (string=? (car l1)(car l2)))#f)
  93       (#t (bom2:match-list? (cdr l1)(cdr l2))))))
  94
  95 (define bom2:match?
  96   (lambda (uref attriblist bomlist)
  97     (if (null? bomlist)
  98       (list (cons (list uref) attriblist))
  99       (if (bom2:match-list? attriblist (cdar bomlist))
 100 ;;        (cons (cons (cons uref (caar bomlist)) (cdar bomlist))(cdr bomlist))
 101         (cons (cons (merge (list uref) (caar bomlist) string<? ) (cdar bomlist))(cdr bomlist))
 102         (cons (car bomlist)(bom2:match? uref attriblist (cdr bomlist)))))))
 103
 104 (define (bom2:in-bom? package)
 105   (string=? "unknown"
 106             (gnetlist:get-package-attribute package "nobom")))
 107
 108 (define (bom2:components-impl ls attriblist bomlist)
 109   (if (null? ls)
 110       (reverse bomlist)
 111       (let* ((package (car ls))
 112              (attribs (bom2:find-attribs package attriblist)))
 113         (bom2:components-impl (cdr ls) attriblist
 114                               (if (bom2:in-bom? package)
 115                                   (bom2:match? package attribs bomlist)
 116                                   bomlist)))))
 117
 118 (define (bom2:components ls attriblist)
 119    (bom2:components-impl ls attriblist '()))
 120
 121 (define bom2:find-attribs
 122   (lambda (package attriblist)
 123     (if (null? attriblist)
 124         '()
 125         (cons (gnetlist:get-package-attribute package (car attriblist))
 126               (bom2:find-attribs package (cdr attriblist))))))
 127
 128 ;;
 129 ;; Bill of Material backend written by Matt Ettus ends here
 130 ;;
 131 ;; --------------------------------------------------------------------------
 132