gnetlist/scheme/gnet-allegro.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 ;; Allegro netlist format
  22
  23
  24 (define allegro:write-device-files
  25    (lambda (packages done)
  26       (if (not (null? packages))
  27          (let ((device (get-device (car packages))))
  28             (if (contains? done device)
  29                (allegro:write-device-files (cdr packages) done)
  30                (begin
  31                   (allegro:write-device device (car packages))
  32                   (allegro:write-device-files (cdr packages) (cons device done))))))))
  33
  34 (define allegro:write-device
  35    (lambda (device package)
  36
  37       ;; Check if the 'devfiles' directory exist.
  38       (if (not (access? "devfiles" F_OK))
  39           (if (access? "." W_OK)
  40               ;; If the 'devfiles' directory doesn't exist, and
  41               ;; we have write access to the current directory, then create it.
  42               (mkdir "devfiles")
  43               ;; If we don't have write access to the current directory,
  44               ;; end with an error message.
  45               (begin
  46                 (error (string-append
  47                         "the device files are expected to be in the 'devfiles' directory.\n"
  48                         "       However, can't create it!.\n"
  49                         "       Check write permissions of the current directory.\n"))))
  50           ;; If 'devfiles' exist, check if it is a directory.
  51           (if (not (eq? (stat:type (stat "devfiles")) 'directory))
  52               (begin
  53                 ;; 'devfiles' exists, but it is not a directory.
  54                 ;; End with an error message.
  55                 (error (string-append
  56                         "the device files are expected to be in the 'devfiles' directory.\n"
  57                         "       However, 'devfiles' exists and it is not a directory!.\n"))
  58                 )))
  59       ;; 'devfiles' should exist now. Check if we have write access.
  60       (if (not (access? "devfiles" W_OK))
  61           ;; We don't have write access to 'devfiles'.
  62           ;; End with an error message
  63           (error (string-append
  64                   "the device files are expected to be in the 'devfiles' directory.\n"
  65                   "       However, can't access it for writing!.\n"
  66                   "       Check write permissions of the 'devfiles' directory.\n")))
  67
  68
  69       (let ((p (open-output-file (string-downcase! (string-append "devfiles/" (string-append device ".txt"))))))
  70          (display "(Device File generated by gEDA Allegro Netlister)\n" p)
  71          (display "PACKAGE " p)
  72          (display (gnetlist:get-package-attribute package "footprint" )p)
  73          (newline p)
  74          (display "CLASS " p)
  75          (display (gnetlist:get-package-attribute package "class" )p)
  76          (newline p)
  77          (display "PINCOUNT " p)
  78          (display (gnetlist:get-package-attribute package "pins" )p)
  79          (newline p)
  80          (let ((altfoot (gnetlist:get-package-attribute package "alt_foot")))
  81             (if (not (string=? altfoot "unknown"))
  82                (begin
  83                   (display "PACKAGEPROP   ALT_SYMBOLS\n" p)
  84                   (display "'(" p)
  85                   (display altfoot p)
  86                   (display ")'\n" p))))
  87          (display "END\n" p)
  88          (close-output-port p))))
  89
  90 (define allegro:components
  91    (lambda (port packages)
  92       (if (not (null? packages))
  93          (begin
  94             (let ((footprint (gnetlist:get-package-attribute (car packages)
  95                                                            "footprint"))
  96                   (package (car packages)))
  97                (if (not (string=? footprint "unknown"))
  98                   (display footprint port))
  99                (display "! " port)
 100                (display (gnetlist:get-package-attribute package "device") port)
 101                (display "! " port)
 102                (display (get-component-text package) port)
 103                (display "; " port )
 104                (display package port)
 105                (newline port))
 106             (allegro:components port (cdr packages))))))
 107
 108 (define allegro:display-connections
 109    (lambda (port nets)
 110       (if (not (null? nets))
 111          (begin
 112             (write-char #\space port)
 113             (display (car (car nets)) port)
 114             (write-char #\. port)
 115             (display (car (cdr (car nets))) port)
 116             (if (null? (cdr nets))
 117                (newline port)
 118                (begin
 119                   (write-char #\, port)
 120                   (newline port)
 121                   (allegro:display-connections port (cdr nets))
 122                 ))))))
 123
 124 (define allegro:write-net
 125    (lambda (port netnames)
 126       (if (not (null? netnames))
 127          (let ((netname (car netnames)))
 128             (display netname port)
 129             (display ";" port)
 130             (allegro:display-connections port (gnetlist:get-all-connections netname))
 131             (allegro:write-net port (cdr netnames))))))
 132
 133 (define allegro
 134    (lambda (filename)
 135       (let ((port (open-output-file filename)))
 136          (display "(Allegro netlister by M. Ettus)\n" port)
 137          (display "$PACKAGES\n" port)
 138          (allegro:components port packages)
 139          (display "$NETS\n" port)
 140          (allegro:write-net port (gnetlist:get-all-unique-nets "dummy"))
 141          (display "$END\n" port)
 142          (close-output-port port)
 143          (allegro:write-device-files packages '() ))))
 144