CoreConvert.scheme
Copyright Ó 1989 by Xerox Corporation. All rights reserved.
Barth, May 15, 1989 3:47:26 pm PDT
(define handle-descriptor (make-record-type 'handle '(
stream
info
id)))
(define make-handle (record-constructor handle-descriptor))
(define handle-stream (record-accessor handle-descriptor 'stream))
(define handle-info (record-accessor handle-descriptor 'info))
(define handle-id (record-accessor handle-descriptor 'id))
(define set-handle-id! (record-updater handle-descriptor 'id))
(define cell-type-info-descriptor (make-record-type 'cell-type-info '(
name
written)))
(define make-cell-type-info (record-constructor cell-type-info-descriptor))
(define cell-type-info-name (record-accessor cell-type-info-descriptor 'name))
(define cell-type-info-written (record-accessor cell-type-info-descriptor 'written))
(define set-cell-type-info-written! (record-updater cell-type-info-descriptor 'written))
(define (gen-cell-type-info handle cell-type)
(define cell-id (string-append "Cell" (int-to-string (handle-id handle))))
(define cell-name (cell-type-name cell-type))
(define cell-type-info (make-cell-type-info cell-id #f))
(set-handle-id! handle (+ (handle-id handle) 1))
(set! cell-type (cell-type-to-basic cell-type))
(if cell-name (set! cell-id (string-append cell-id cell-name)))
(table-set! (handle-info handle) cell-type cell-type-info)
cell-type-info
)
(define (my-display string port)
(display string port)
)
(define (convert-cell-type handle cell-type)
(set! cell-type (cell-type-to-basic cell-type))
(let ((cell-type-info (table-ref (
handle-info handle) cell-type)))
(if (or (not cell-type-info) (not (cell-type-info-written cell-type-info)))
(begin
(if (not cell-type-info) (set! cell-type-info (gen-cell-type-info handle cell-type)))
(set-cell-type-info-written! cell-type-info #t)
(cond
((eqv? (cell-type-class cell-type) (transistor-cell-class)))
((eqv? (cell-type-class cell-type) (record-cell-class))
(write-record-cell handle cell-type cell-type-info)
)
(else (display "Illegal cell class encountered"))
)
)
)
)
)
(define (write-record-cell handle cell-type cell-type-info)
(define port (handle-stream handle))
(define wire-id-tab (make-table))
(define wire-count 0)
(define id-count 0)
(define (public-name public-wire prefix index)
(define name (wire-name-short public-wire))
(if (eqv? name nil)(set! name (int-to-string index)))
(string-append (if prefix (string-append prefix "x") "x") name)
)
(define (write-public public-wire name)
(define public-size (wire-size public-wire))
(if (= 0 public-size)
(begin
(if (= 0 wire-count) (my-display "PARAMETER = " port)
(my-display ", " port)
)
(my-display name port)
(table-set! wire-id-tab public-wire name)
(set! wire-count (+ 1 wire-count))
)
(begin
(do ((i 0 (+ i 1))) ((= i public-size))
(let ((subwire (wire-child public-wire i)))
(write-public subwire
(public-name subwire name i)
)
)
)
)
)
)
(define (write-bind actual public public-name-prefix)
(define actual-size (wire-size actual))
(if (> actual-size 0)
(do ((i 0 (+ i 1))) ((= i actual-size))
(let ((public-child (wire-child public i)))
(if (not (= actual-size (wire-size public)))
(begin
(display " public ")
(display (wire-size public))
(display " actual ")
(display actual-size)
)
)
(write-bind
(wire-child actual i)
public-child
(public-name public-child public-name-prefix i)
)
)
)
(begin
(let ((actual-name (table-ref wire-id-tab actual)))
(if (> wire-count 0) (my-display ", " port))
(my-display public-name-prefix port)
(my-display "=" port)
(if (eqv? actual-name nil)
(begin
(set! actual-name (string-append "NUL%" (int-to-string id-count)))
(set! id-count (+ 1 id-count))
(table-set! wire-id-tab actual actual-name)
)
)
(my-display actual-name port)
(set! wire-count (+ 1 wire-count))
)
)
)
)
(define rct (cell-type-data cell-type))
(define rct-size (record-cell-type-size rct))
(my-display "\nMNAME = " port)
(my-display (cell-type-info-name cell-type-info) port)
(my-display ";\n" port)
(begin
(let*
(
(public (cell-type-public cell-type))
(public-size (wire-size public))
)
(do ((i 0 (+ i 1))) ((= i public-size))
(let ((subwire (wire-child public i)))
(write-public subwire
(public-name subwire nil i)
)
)
)
)
)
(if (> wire-count 0) (my-display ";\n" port))
(do ((i 0 (+ i 1))) ((= i rct-size))
(let*
(
(instance (record-cell-type-instance rct i))
(subtype (cell-instance-type instance))
)
(if (eqv? (cell-type-class subtype) (record-cell-class))
(begin
(let ((subinfo (table-ref (
handle-info handle) subtype)))
(if (eqv? subinfo nil) (set! subinfo (gen-cell-type-info handle subtype)))
(my-display (cell-type-info-name subinfo) port)
(set! wire-count 0)
(my-display "(" port)
(write-bind (cell-instance-actual instance) (cell-type-public subtype) nil)
(my-display ");\n" port)
)
)
)
)
)
(my-display "END;\n" port)
(do ((i 0 (+ i 1))) ((= i rct-size))
(convert-cell-type
handle
(cell-instance-type
(record-cell-type-instance rct i)
)
)
)
)
(define (cell-type-to-file cell-type file-name)
(define handle
(make-handle
(open-output-file file-name)
(make-table)
0
)
)
(convert-cell-type handle cell-type)
(close-output-port (handle-stream handle))
)
(define (convert-current)
(define cell-type (current-cell-type))
(cell-type-to-file cell-type
(string-append (cell-type-name cell-type) ".cvt")
)
)