gnetlist/scheme/gnet-bom2.scm

   1 ;;; $Id$
   2 ;;;
   3 ;;; gEDA - GNU Electronic Design Automation
   4 ;;; gnetlist - GNU Netlist
   5 ;;; Copyright (C) 1998-2001 Ales V. Hvezda
   6 ;;;
   7 ;;; This program is free software; you can redistribute it and/or modify
   8 ;;; it under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 2 of the License, or
  10 ;;; (at your option) any later version.
  11 ;;;
  12 ;;; This program is distributed in the hope that it will be useful,
  13 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with this program; if not, write to the Free Software
  19 ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20
  21
  22 ;; --------------------------------------------------------------------------
  23 ;;
  24 ;; Bill of Material backend written by Matt Ettus starts here
  25 ;;
  26
  27 ;;; Bill Of Materials Generator
  28 ;;; You must have a file called attribs in the pwd
  29 ;;; The file should be a text list of attributes you want listed,
  30 ;;; One per line.  No comments are allowed in the file.
  31 ;;; Questions? Contact matt@ettus.com
  32 ;;; This software is released under the terms of the GNU GPL
  33
  34 (use-modules (ice-9 rdelim)) ;; guile-1.8 fix
  35
  36 (define bom2
  37   (lambda (output-filename)
  38     (let ((port (if (string=? "-" output-filename)
  39                       (current-output-port)
  40                       (open-output-file output-filename)))
  41           (attriblist (bom2:parseconfig (open-input-file "attribs"))))
  42       (bom2:printlist (cons 'refdes attriblist) port #\:)
  43       (newline port)
  44       (bom2:printbom port (bom2:components packages attriblist))
  45       (close-output-port port))))
  46
  47 (define bom2:printbom
  48   (lambda (port bomlist)
  49     (if (not (null? bomlist))
  50       (if (not (null? (caar bomlist)))
  51         (begin
  52           (display (caaar bomlist) port)
  53           (if (not (null? (cdaar bomlist)))
  54             (write-char #\, port))
  55           (bom2:printbom port (cons (cons (cdaar bomlist)(cdar bomlist))(cdr bomlist))))
  56         (begin
  57           (display #\: port)
  58           (bom2:printlist (cdar bomlist) port #\:)
  59           (newline port)
  60           (bom2:printbom port (cdr bomlist)))))))
  61
  62 (define bom2:printlist
  63   (lambda (ls port delimiter)
  64     (if (null? ls)
  65         #f
  66         (begin
  67           (display (car ls) port)
  68           (if (not (null? (cdr ls)))
  69             (write-char delimiter port))
  70           (bom2:printlist (cdr ls) port delimiter)))))
  71
  72 ; Parses attrib file. Returns a list of read attributes.
  73 (define bom2:parseconfig
  74   (lambda (port)
  75     (let ((read-from-file (read-delimited " \n\t" port)))
  76       (cond ((eof-object? read-from-file)
  77              '())
  78             ((= 0 (string-length read-from-file))
  79              (bom2:parseconfig port))
  80             (else
  81              (cons read-from-file (bom2:parseconfig port)))))))
  82
  83 (define bom2:match-list?
  84   (lambda (l1 l2)
  85     (cond
  86       ((and (null? l1)(null? l2))#t)
  87       ((null? l1) #f)
  88       ((null? l2) #f)
  89       ((not (string=? (car l1)(car l2)))#f)
  90       (#t (bom2:match-list? (cdr l1)(cdr l2))))))
  91
  92 (define bom2:match?
  93   (lambda (uref attriblist bomlist)
  94     (if (null? bomlist)
  95       (list (cons (list uref) attriblist))
  96       (if (bom2:match-list? attriblist (cdar bomlist))
  97 ;;        (cons (cons (cons uref (caar bomlist)) (cdar bomlist))(cdr bomlist))
  98         (cons (cons (merge (list uref) (caar bomlist) string<? ) (cdar bomlist))(cdr bomlist))
  99         (cons (car bomlist)(bom2:match? uref attriblist (cdr bomlist)))))))
 100
 101 (define bom2:components
 102   (lambda (ls attriblist)
 103     (if (null? ls)
 104       '()
 105       (let ((package (car ls))
 106             (bomlist (bom2:components (cdr ls) attriblist))
 107             (attribs (bom2:find-attribs (car ls) attriblist)))
 108         (if (not (string=? "unknown" (gnetlist:get-package-attribute package "nobom")))
 109           bomlist
 110           (bom2:match? package attribs bomlist))))))
 111
 112 (define bom2:find-attribs
 113   (lambda (package attriblist)
 114     (if (null? attriblist)
 115         '()
 116         (cons (gnetlist:get-package-attribute package (car attriblist))
 117               (bom2:find-attribs package (cdr attriblist))))))
 118
 119 ;;
 120 ;; Bill of Material backend written by Matt Ettus ends here
 121 ;;
 122 ;; --------------------------------------------------------------------------
 123