/usr/share/scsh-0.6/link/generate-old-c-header.scm is in scsh-common-0.6 0.6.7-8.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 | ; 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))))))))))
|