scsh-0.6/scheme/link/generate-old-c-header.scm

161 lines
5.2 KiB
Scheme

; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
; This for compatibility with pre-0.53 code.
; [This is a kludge. Richard is loathe to include it in the
; distribution.]
; Reads arch.scm and data.scm and writes out a C .h file with constants
; and macros for dealing with Scheme 48 data structures.
; Needs Big Scheme.
; (make-c-header-file "scheme48.h" "vm/arch.scm" "vm/data.scm")
(define (make-c-header-file c-file arch-file data-file)
(receive (stob-list stob-data)
(search-file arch-file
'("stob enumeration" "(define stob-data ...)")
(defines-enum? 'stob)
enum-definition-list
(lambda (x)
(and (eq? (car x) 'define)
(eq? (cadr x) 'stob-data)))
(lambda (x) (cadr (caddr x))))
(receive (tag-list immediate-list)
(search-file data-file
'("tag enumeration" "imm enumeration")
(defines-enum? 'tag)
enum-definition-list
(defines-enum? 'imm)
enum-definition-list)
(with-output-to-file c-file
(lambda ()
(format #t "typedef long scheme_value;~%~%")
(tag-stuff tag-list)
(newline)
(immediate-stuff immediate-list)
(newline)
(stob-stuff stob-list stob-data))))))
(define (tag-stuff tag-list)
(do ((tags tag-list (cdr tags))
(i 0 (+ i 1)))
((null? tags))
(let ((name (upcase (car tags))))
(c-define "~A_TAG ~D" name i)
(c-define "~AP(x) (((long)(x) & 3L) == ~A_TAG)" name name)))
(newline)
(c-define "ENTER_FIXNUM(n) ((scheme_value)((n) << 2))")
(c-define "EXTRACT_FIXNUM(x) ((long)(x) >> 2)"))
(define (immediate-stuff imm-list)
(c-define "MISC_IMMEDIATE(n) (scheme_value)(IMMEDIATE_TAG | ((n) << 2))")
(do ((imm imm-list (cdr imm))
(i 0 (+ i 1)))
((null? imm))
(let ((name (upcase (car imm))))
(c-define "SCH~A MISC_IMMEDIATE(~D)" name i)))
(c-define "UNDEFINED SCHUNDEFINED")
(c-define "UNSPECIFIC SCHUNSPECIFIC")
(newline)
(c-define "ENTER_BOOLEAN(n) ((n) ? SCHTRUE : SCHFALSE)")
(c-define "EXTRACT_BOOLEAN(x) ((x) != SCHFALSE)")
(newline)
(c-define "ENTER_CHAR(c) (SCHCHAR | ((c) << 8))")
(c-define "EXTRACT_CHAR(x) ((x) >> 8)")
(c-define "CHARP(x) ((((long) (x)) & 0xff) == SCHCHAR)"))
(define (stob-stuff stob-list stob-data)
(let ((type-mask (let ((len (length stob-list)))
(do ((i 2 (* i 2)))
((>= i len) (- i 1))))))
(c-define "ADDRESS_AFTER_HEADER(x, type) ((type *)((x) - STOB_TAG))")
(c-define "STOB_REF(x, i) ((ADDRESS_AFTER_HEADER(x, long))[i])")
(c-define "STOB_TYPE(x) ((STOB_HEADER(x)>>2)&~D)" type-mask)
(c-define "STOB_HEADER(x) (STOB_REF((x),-1))")
(c-define "STOB_BLENGTH(x) (STOB_HEADER(x) >> 8)")
(c-define "STOB_LLENGTH(x) (STOB_HEADER(x) >> 10)")
(newline)
(do ((stob stob-list (cdr stob))
(i 0 (+ i 1)))
((null? stob))
(let ((name (upcase (if (eq? (car stob) 'byte-vector)
'code-vector
(car stob)))))
(c-define "STOBTYPE_~A ~D" name i)
(c-define "~AP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_~A))"
name name)))
(newline)
(for-each (lambda (data)
(do ((accs (cdddr data) (cdr accs))
(i 0 (+ i 1)))
((null? accs))
(let ((name (upcase (caar accs))))
(c-define "~A(x) STOB_REF(x, ~D)" name i))))
stob-data)
(newline)
(c-define "VECTOR_LENGTH(x) STOB_LLENGTH(x)")
(c-define "VECTOR_REF(x, i) STOB_REF(x, i)")
(c-define "CODE_VECTOR_LENGTH(x) STOB_BLENGTH(x)")
(c-define "CODE_VECTOR_REF(x, i) (ADDRESS_AFTER_HEADER(x, unsigned char)[i])")
(c-define "STRING_LENGTH(x) (STOB_BLENGTH(x)-1)")
(c-define "STRING_REF(x, i) (ADDRESS_AFTER_HEADER(x, char)[i])")))
; - becomes _ > becomes TO_ (so -> turns into _TO_)
; ? becomes P
(define (upcase symbol)
(do ((chars (string->list (symbol->string symbol)) (cdr chars))
(res '() (case (car chars)
((#\>) (append (string->list "_OT") res))
((#\-) (cons #\_ res))
((#\?) (cons #\P res))
(else (cons (char-upcase (car chars)) res)))))
((null? chars)
(list->string (reverse res)))))
(define (c-define string . stuff)
(format #t "#define ~?~%" string stuff))
(define (defines-enum? name)
(lambda (x)
(and (eq? (car x) 'define-enumeration)
(eq? (cadr x) name))))
(define enum-definition-list caddr)
; STUFF is list of ((predicate . extract) . name). <name> is replaced
; with the value when it is found.
(define (search-file file what-for . pred+extract)
(let ((stuff (do ((p+e pred+extract (cddr p+e))
(names what-for (cdr names))
(ps '() (cons (cons (cons (car p+e) (cadr p+e))
(car names))
ps)))
((null? p+e) (reverse ps)))))
(define (search next not-found)
(let loop ((n-f not-found) (checked '()))
(cond ((null? n-f)
#f)
(((caaar n-f) next)
(set-cdr! (car n-f) ((cdaar n-f) next))
(append (reverse checked) (cdr n-f)))
(else
(loop (cdr n-f) (cons (car n-f) checked))))))
(with-input-from-file file
(lambda ()
(let loop ((not-found stuff))
(let ((next (read)))
(cond ((null? not-found)
(apply values (map cdr stuff)))
((eof-object? next)
(error "file ~S doesn't have ~A" file (cdar not-found)))
(else
(loop (or (and (pair? next)
(search next not-found))
not-found))))))))))