gnetlist/scheme/gnet-PCBboard.scm.in

   1 ;;; $Id$
   2 ;;;
   3 ;;; gEDA - GNU Electronic Design Automation
   4 ;;; gnetlist - GNU Netlist
   5 ;;; Copyright (C) 1998-2000 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 ;;  PCBboard format
  22 ;; JM Routoure & Stefan Petersen
  23 ;; 15/01/99
  24
  25
  26 ;;
  27 ;;
  28 (define PCBboard:write-top-header
  29   (lambda (port)
  30     (display "# release: pcb 1.6.3\n" port)
  31     (display "PCB(\"\" 6000 5000)\n" port)
  32     (display "Grid(10 0 0)\n" port)
  33     (display "Cursor(10 270 3)\n" port)
  34     (display "Flags(0x000000d0)\n" port)
  35     (display "Groups(\"1,2,3,s:4,5,6,c:7:8:\")\n" port)
  36     (display "Styles(\"Signal,10,40,20:Power,25,60,35:Fat,40,60,35:Skinny,8,36,20\")\n" port)))
  37
  38
  39 ;;
  40 ;;
  41 (define PCBboard:write-bottom-footer
  42   (lambda (port)
  43     (display "Layer(1 \"solder\")\n(\n)\n" port)
  44     (display "Layer(2 \"GND-sldr\")\n(\n)\n" port)
  45     (display "Layer(3 \"Vcc-sldr\")\n(\n)\n" port)
  46     (display "Layer(4 \"component\")\n(\n)\n" port)
  47     (display "Layer(5 \"GND-comp\")\n(\n)\n" port)
  48     (display "Layer(6 \"Vcc-comp\")\n(\n)\n" port)
  49     (display "Layer(7 \"unused\")\n(\n)\n" port)
  50     (display "Layer(8 \"unused\")\n(\n)" port)
  51     (newline port)))
  52
  53 ;;
  54 ;;
  55
  56 ;; Split string at current split-char and returns
  57 ;; a pair with substrings. If string is not splitable
  58 ;; it returns #f.
  59 (define (string-split the-string split-char)
  60 ;;string-index is Guile specific
  61   (let ((split-index (string-index the-string split-char))
  62         (last-index (- (string-length the-string) 1)))
  63 ;;Check if split-char happens to be in the beginning or end of the string
  64     (cond ((not split-index)
  65            #f)
  66           ((= split-index 0)
  67            (string-split
  68             (substring the-string 1 (string-length the-string))
  69             split-char))
  70           ((= split-index last-index)
  71            #f)
  72           (split-index
  73            (cons (substring the-string 0 split-index)
  74                  (substring the-string (+ split-index 1)
  75                             (string-length the-string))))
  76           (else
  77            #f))))
  78
  79 ;; Splits a string with space separated words and returns a list
  80 ;; of the words (still as strings).
  81 (define (split-to-list the-string)
  82   (let ((the-list (string-split the-string #\space)))
  83     (if the-list
  84         (cons (car the-list) (split-to-list (cdr the-list)))
  85         (list the-string))))
  86
  87
  88 ;; Check if the string has a space
  89 (define (has-space? the-string)
  90   (string-index the-string #\space))
  91
  92
  93 (define PCBboard:write-value-footprint
  94   (lambda (pipe ls)
  95     (if (not (null? ls))
  96 ;;       uref contains the first element of ls
  97         (let* ((uref (car ls))
  98                (value (gnetlist:get-package-attribute uref "value"))
  99                (device (gnetlist:get-package-attribute uref "device"))
 100 ;; The footprint attribute is used by gschem to indicate the footprint
 101                (footprint (split-to-list
 102                           (gnetlist:get-package-attribute uref  "footprint") ) ) )
 103
 104 ;; Test if uref contains a space char
 105           (cond ((has-space? uref)
 106                  (display (string-append "ERROR!, space character found in the value of " uref))
 107                  (newline))
 108 ;; Test if device contains a space char
 109                 ((has-space? device)
 110                  (display (string-append "ERROR!, space character found in the device attribute of " uref))
 111                  (newline))
 112 ;; Test if value contains a space char
 113                 ((has-space? value)
 114                  (display (string-append "ERROR!, space character found in the value of " uref))
 115                  (newline))
 116 ;; Test if value contains a space char
 117                 ((string=? (car footprint) "unknown")
 118                  (display (string-append "ERROR! no footprint attribute in " uref ))
 119                  (newline))
 120                 (else
 121                  (display (string-append "PKG_" (car footprint)) pipe)
 122                  (display (string-append "(`" device "',`" uref "',`") pipe)
 123                  (display value pipe)
 124                  (case (length footprint)
 125                    ((1) #f)
 126                    ((2) (display (string-append "',`" (cadr footprint)) pipe))
 127                    ((3) (display (string-append "',`" (cadr footprint)
 128                                          "',`" (caddr footprint)) pipe))
 129                    (else (display (string-append "ERROR!, no footprint in device " uref))))
 130                  (display "')" pipe)
 131                  (newline pipe)
 132                  (PCBboard:write-value-footprint pipe (cdr ls))))))))
 133
 134
 135 ;;
 136 ;;
 137
 138 (define m4-command "@m4@")
 139 (define m4-files "")
 140 (define *m4-pcbdir* "@pcbm4dir@")
 141 (define *m4-pcbconfdir* "@pcbconfdir@")
 142
 143 ;; To emulate popen. Guileish again.
 144 ; Needed after guile ver. 1.3.2. To save 1.3a users, wrap it in.
 145 ; This does not work with guile 1.6.3: (false-if-exception (use-modules ... ))
 146 ; The below should work everywhere.
 147 (use-modules (ice-9 popen))
 148
 149 (define (PCBboard output-filename)
 150   (let ((port (open-output-file output-filename)))
 151     (PCBboard:write-top-header port)
 152        (close-port port))
 153        ;; pipe with the macro define in pcb program
 154 ;;  (let ((pipe (open-output-pipe (string-append "m4 " *m4-pcbdir* "/common.m4 - | sed '/^PKG/d' - >> " output-filename))))
 155 ;;  leave the packages that have not been found in the file.pcb
 156 ;;  will be process in the script gschem2pcb
 157 ;; Original pipe command commented out by AVH (bugfix by Rich Walker)
 158 ;;  (let ((pipe (open-output-pipe (string-append "m4 " *m4-pcbdir* "/common.m4 - >> " output-filename))))
 159 ;; Fixed pipe command (AVH 1/27/02)
 160    (let ((pipe (open-output-pipe (string-append m4-command " -d -I" *m4-pcbdir* " -I" *m4-pcbconfdir* " -I $HOME/.pcb -I. " *m4-pcbdir* "/common.m4 - >> " output-filename))))
 161
 162
 163        ;; packages is a list with the different uref value
 164     (PCBboard:write-value-footprint pipe packages)
 165        (close-pipe pipe))
 166   (let ((port (open output-filename (logior O_WRONLY O_APPEND))))
 167     (PCBboard:write-bottom-footer port)
 168        close-port port))