374 lines
12 KiB

; -*- 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.
; (process <filename>)
; where the file is the output of ffigen.
; There are some general instructions in the section marked CUSTOMIZABLE
; below.
; 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)
(display warnings) (display " warnings.") (newline)
(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)
; 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))
(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))
(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)
(for-each t-ref (arglist t))
(t-ref (rett t)))
(let ((struct (lookup (tag t) structs)))
(if (not (referenced? struct))
(begin (referenced! struct)
(set! ref-queue (cons struct ref-queue))))))
(let ((union (lookup (tag t) unions)))
(if (not (referenced? union))
(begin (referenced! union)
(set! ref-queue (cons union ref-queue))))))
(t-ref (cadr t)))
(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)))
(set! ref-queue '())
(for-each (lambda (f)
(if (referenced? f)
(t-ref (type f))))
(for-each (lambda (v)
(t-ref (type v)))
; 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)
(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))))
(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))
(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)
(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