374 lines
12 KiB
Scheme
374 lines
12 KiB
Scheme
; -*- scheme -*-
|
|
;
|
|
; Generic program to process output from ffigen.
|
|
; Lars Thomas Hansen [lth@cs.uoregon.edu] / January 29, 1996
|
|
;
|
|
; Copyright (C) 1996 The University of Oregon. All rights reserved.
|
|
;
|
|
; This file may be freely redistributed in its entirety with or without
|
|
; modification provided that this copyright notice is not removed. It
|
|
; may not be sold for profit or incorporated in commercial software
|
|
; products without the prior written permission of the copyright holder.
|
|
;
|
|
; USAGE
|
|
; (process <filename>)
|
|
; where the file is the output of ffigen.
|
|
;
|
|
; DESCRIPTION
|
|
; There are some general instructions in the section marked CUSTOMIZABLE
|
|
; below.
|
|
;
|
|
; INPUT FORMAT
|
|
; Input consists of s-expressions of the following forms:
|
|
; <record> -> (function <filename> <name> <type> <attrs>)
|
|
; | (var <filename> <name> <type> <attrs>)
|
|
; | (type <filename> <name> <type>)
|
|
; | (struct <filename> <name> ((<name> <type>) ...))
|
|
; | (union <filename> <name> ((<name> <type>) ...))
|
|
; | (enum <filename> <name> ((<name> <value>) ...))
|
|
; | (enum-ident <filename> <name> <value>)
|
|
; | (macro <filename> <name+args> <body>)
|
|
;
|
|
; <type> -> (<primitive> <attrs>)
|
|
; | (struct-ref <tag>)
|
|
; | (union-ref <tag>)
|
|
; | (enum-ref <tag>)
|
|
; | (function (<type> ...) <type>)
|
|
; | (pointer <type>)
|
|
; | (array <value> <type>)
|
|
; <attrs> -> (<attr> ...)
|
|
; <attr> -> static | extern | const | volatile
|
|
;
|
|
; <primitive> -> char | signed-char | unsigned-char | short | unsigned-short
|
|
; | int | unsigned | long | unsigned-long | void
|
|
;
|
|
; <value> -> <integer>
|
|
; <filename> -> <string>
|
|
; <name> -> <string>
|
|
; <body> -> <string>
|
|
; <name+args> -> <string>
|
|
;
|
|
; Functions which are known to take no parameters (i.e. t f(void)) have
|
|
; one parameter, of type "void".
|
|
;
|
|
; Functions which have a variable number of arguments have at least one
|
|
; defined parameter and a last parameter of type "void".
|
|
;
|
|
; The ordering of records in the input have little or no relation to the
|
|
; relative ordering of declarations in the original source.
|
|
;
|
|
; Multidimensional arrays are represented as nested array types with the
|
|
; leftmost dimension outermost in the expected way; i.e., it looks like
|
|
; an array of arrays.
|
|
;
|
|
; Not all attributes are possible in all places, of course.
|
|
;
|
|
; Unresolved issues:
|
|
; - Handling of bitfields. Might want primitive types (bitfield n)
|
|
; and (unsigned-bitfield n), but alignment is a real issue. Another
|
|
; option is a field which contains all the bitfield in it:
|
|
; (bitfield (i 0 3) (j 3 4) (k 7 10)) says that i starts at bit 0 and
|
|
; is 3 bits long, etc. Ditto unsigned.
|
|
; - Transmission of compiler-computed alignment and size data in general.
|
|
; - Evaluation of macros as far as possible; use of integer values where
|
|
; reasonable.
|
|
|
|
(define functions '()) ; list of function records
|
|
(define vars '()) ; list of var records
|
|
(define types '()) ; list of type records
|
|
(define structs '()) ; list of struct records
|
|
(define unions '()) ; list of union records
|
|
(define macros '()) ; list of macro records
|
|
(define enums '()) ; list of enum records
|
|
(define enum-idents '()) ; list of enum-ident records
|
|
|
|
(define source-file #f) ; name of the input file itself
|
|
(define filenames '()) ; names of all files in the input
|
|
|
|
(define caddddr (lambda (x) (car (cddddr x))))
|
|
|
|
(define warnings 0)
|
|
|
|
(define (process filename)
|
|
(set! source-file filename)
|
|
(set! functions '())
|
|
(set! vars '())
|
|
(set! types '())
|
|
(set! structs '())
|
|
(set! unions '())
|
|
(set! macros '())
|
|
(set! enums '())
|
|
(set! enum-idents '())
|
|
(set! filenames '())
|
|
(set! warnings 0)
|
|
(call-with-input-file filename
|
|
(lambda (p)
|
|
(do ((item (read p) (read p)))
|
|
((eof-object? item)
|
|
(process-records)
|
|
(newline)
|
|
(display warnings) (display " warnings.") (newline)
|
|
#t)
|
|
(let ((fn (name item)))
|
|
(if (not (member fn filenames))
|
|
(set! filenames (cons fn filenames))))
|
|
(case (car item)
|
|
((function) (set! functions (cons item functions)))
|
|
((var) (set! vars (cons item vars)))
|
|
((type) (set! types (cons item types)))
|
|
((struct) (set! structs (cons item structs)))
|
|
((union) (set! unions (cons item unions)))
|
|
((macro) (set! macros (cons item macros)))
|
|
((enum) (set! enums (cons item enums)))
|
|
((enum-ident) (set! enum-idents (cons item enum-idents)))
|
|
(else (error 'process "~a" item)))))))
|
|
|
|
; Processing after reading.
|
|
|
|
(define (process-records)
|
|
(select-functions)
|
|
(compute-referenced-types)
|
|
(generate-translation))
|
|
|
|
; File name utilities.
|
|
|
|
(define (strip-extension fn)
|
|
(do ((i (- (string-length fn) 1) (- i 1)))
|
|
((or (< i 0)
|
|
(char=? (string-ref fn i) #\.)
|
|
(char=? (string-ref fn i) #\/))
|
|
(if (and (>= i 0) (char=? (string-ref fn i) #\.))
|
|
(substring fn 0 i)
|
|
(string-copy fn)))))
|
|
|
|
(define (strip-path fn)
|
|
(do ((i (- (string-length fn) 1) (- i 1)))
|
|
((or (< i 0)
|
|
(char=? (string-ref fn i) #\/))
|
|
(if (and (>= i 0) (char=? (string-ref fn i) #\/))
|
|
(substring fn (+ i 1) (string-length fn))
|
|
(string-copy fn)))))
|
|
|
|
(define (get-path fn)
|
|
(let ((x (strip-path fn)))
|
|
(if (= (string-length fn) (string-length x))
|
|
x
|
|
(substring fn 0 (- (string-length fn) (string-length x))))))
|
|
|
|
; Accessors.
|
|
;
|
|
; Representation: Each <record> and <type> is represented exactly like it
|
|
; was in the input _except_ for the first element. The element is either
|
|
; the symbol like it was in the input, or a pair. If it is a pair, then
|
|
; the car of the pair is the symbol from the input and the cdr is
|
|
; system-internal information. It's a list which currently holds:
|
|
; (referenced-bit cached-info)
|
|
;
|
|
; All other data are represented exactly as in the input.
|
|
;
|
|
; Some of the generic functions operate on data structures which do not
|
|
; have a record-tag (fields, for example). They examine the datum to figure
|
|
; out what to do. For example, if the car is a string then it's a field,
|
|
; otherwise it's not.
|
|
|
|
(define file cadr) ; file name in records which have one
|
|
|
|
(define (name x) ; name in records which have one
|
|
(if (string? (car x))
|
|
(car x) ; fields
|
|
(caddr x))) ; others
|
|
|
|
(define (type x) ; type in records which have one
|
|
(if (string? (car x))
|
|
(cadr x) ; fields
|
|
(cadddr x))) ; others
|
|
|
|
(define attrs caddddr) ; attrs in records which have one
|
|
(define fields cadddr) ; fields in struct/union type
|
|
(define value cadddr) ; value of enum-tag record
|
|
|
|
(define (tag x) ; tag in struct-ref/union-ref or struct/union record
|
|
(let ((rt (record-tag x)))
|
|
(if (or (eq? rt 'struct-ref)
|
|
(eq? rt 'union-ref)
|
|
(eq? rt 'enum-ref))
|
|
(cadr x) ; refs
|
|
(caddr x)))) ; others
|
|
|
|
(define arglist cadr) ; function argument list (list of types)
|
|
(define (rett x) (caddr x)) ; function return type
|
|
|
|
(define (record-tag r) ; always use this.
|
|
(if (symbol? (car r))
|
|
(car r)
|
|
(caar r)))
|
|
|
|
(define (sysinfo r)
|
|
(if (symbol? (car r))
|
|
(let ((info (list #f '())))
|
|
(set-car! r (cons (car r) info))
|
|
info)
|
|
(cdar r)))
|
|
|
|
(define (referenced? x) (car (sysinfo x)))
|
|
(define (referenced! x) (set-car! (sysinfo x) #t))
|
|
(define (unreferenced! x) (set-car! (sysinfo x) #f))
|
|
|
|
(define (cache-name r n)
|
|
(let ((i (sysinfo r)))
|
|
(set-car! (cdr i) (cons n (cadr i)))))
|
|
|
|
(define (cached-names r)
|
|
(cadr (sysinfo r)))
|
|
|
|
; Compute the referenced bit for all referenced structure and union types.
|
|
; This may be useful for some systems, and it can be used for getting rid of
|
|
; structures included from "incidental" headers, esp. if only some functions
|
|
; have been selected.
|
|
|
|
(define ref-queue '())
|
|
|
|
(define (compute-referenced-types)
|
|
|
|
(define (t-ref t)
|
|
(case (record-tag t)
|
|
((function)
|
|
(for-each t-ref (arglist t))
|
|
(t-ref (rett t)))
|
|
((struct-ref)
|
|
(let ((struct (lookup (tag t) structs)))
|
|
(if (not (referenced? struct))
|
|
(begin (referenced! struct)
|
|
(set! ref-queue (cons struct ref-queue))))))
|
|
((union-ref)
|
|
(let ((union (lookup (tag t) unions)))
|
|
(if (not (referenced? union))
|
|
(begin (referenced! union)
|
|
(set! ref-queue (cons union ref-queue))))))
|
|
((pointer)
|
|
(t-ref (cadr t)))
|
|
((array)
|
|
(t-ref (caddr t)))))
|
|
|
|
(define (struct/union-loop)
|
|
(if (not (null? ref-queue))
|
|
(let ((queue ref-queue))
|
|
(set! ref-queue '())
|
|
(for-each (lambda (t)
|
|
(for-each (lambda (f)
|
|
(t-ref (cadr f)))
|
|
(fields t)))
|
|
queue)
|
|
(struct/union-loop))))
|
|
|
|
(set! ref-queue '())
|
|
(for-each (lambda (f)
|
|
(if (referenced? f)
|
|
(t-ref (type f))))
|
|
functions)
|
|
(for-each (lambda (v)
|
|
(t-ref (type v)))
|
|
vars)
|
|
(struct/union-loop)
|
|
#t)
|
|
|
|
; Lookup by the 'name' field of whatever it is.
|
|
|
|
(define (lookup key items)
|
|
(do ((items items (cdr items)))
|
|
((or (null? items)
|
|
(string=? key (name (car items))))
|
|
(if (null? items)
|
|
#f
|
|
(car items)))))
|
|
|
|
; Simple macro expander. Given a template (a string) and some arguments
|
|
; (a vector of strings) expand the arguments in the template, returning
|
|
; a fresh string. If an @ is seen in the template, it must be followed by
|
|
; a simple digit which is the index into the argument vector.
|
|
|
|
(define (instantiate template args)
|
|
|
|
(define (get-arg n)
|
|
(reverse (string->list (vector-ref args n))))
|
|
|
|
(let ((limit (string-length template)))
|
|
(let loop ((i 0) (r '()))
|
|
(cond ((= i limit)
|
|
(list->string (reverse r)))
|
|
((char=? (string-ref template i) #\@)
|
|
(let ((k (- (char->integer (string-ref template (+ i 1)))
|
|
(char->integer #\0))))
|
|
(loop (+ i 2) (append (get-arg k) r))))
|
|
(else
|
|
(loop (+ i 1) (cons (string-ref template i) r)))))))
|
|
|
|
; Given a struct, find the names for the structure. The name is the
|
|
; structure tag itself (we'll prefix it by "struct_") and the names of
|
|
; any typedef names which refer directly to the structure.
|
|
|
|
(define (struct-names struct)
|
|
(struct-union-names struct "struct " 'struct-ref))
|
|
|
|
(define (union-names union)
|
|
(struct-union-names union "union " 'union-ref))
|
|
|
|
(define (struct-union-names struct/union srctag reffer)
|
|
(let ((names '()))
|
|
(do ((t types (cdr t)))
|
|
((null? t) names)
|
|
(let ((x (type (car t))))
|
|
(if (and (eq? (record-tag x) reffer)
|
|
(string=? (tag struct/union) (tag x)))
|
|
(set! names (cons (name (car t)) names)))))))
|
|
|
|
(define (user-defined-tag? x)
|
|
(and (> (string-length x) 0)
|
|
(not (char-numeric? (string-ref x 0)))))
|
|
|
|
(define warn
|
|
(let ((out (current-output-port)))
|
|
(lambda (msg . rest)
|
|
(set! warnings (+ warnings 1))
|
|
(display "WARNING: " out)
|
|
(display msg out)
|
|
(for-each (lambda (x)
|
|
(display " " out)
|
|
(display x out))
|
|
rest)
|
|
(newline out))))
|
|
|
|
(define (basic-type? x)
|
|
(or (primitive-type? x)
|
|
(pointer-type? x)))
|
|
|
|
(define (pointer-type? x)
|
|
(eq? (record-tag x) 'pointer))
|
|
|
|
(define (primitive-type? x)
|
|
(memq (record-tag x)
|
|
'(int unsigned short unsigned-short long unsigned-long
|
|
double float char signed-char unsigned-char void)))
|
|
|
|
(define (array-type? x)
|
|
(eq? (record-tag x) 'array))
|
|
|
|
(define (structured-type? x)
|
|
(or (eq? (record-tag x) 'struct-ref)
|
|
(eq? (record-tag x) 'union-ref)))
|
|
|
|
(define canonical-name
|
|
(let ((char-canon-case (if (char=? (string-ref (symbol->string 'a) 0) #\a)
|
|
char-downcase
|
|
char-upcase)))
|
|
(lambda (s)
|
|
(list->string (map char-canon-case (string->list s))))))
|
|
|
|
(define (struct/union-ref record)
|
|
(case (record-tag record)
|
|
((struct) `(struct-ref ,(tag record)))
|
|
((union) `(union-ref ,(tag record)))
|
|
(else (error 'struct/union-ref "What's a " record))))
|
|
|
|
; eof
|