/usr/share/scheme48-1.9/link/write-image.scm is in scheme48 1.9-5.
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 | ; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber
; Writing out a Scheme 48 image
(define (write-image file start-proc id-string)
(if (not (= 0 (remainder bits-per-cell bits-per-io-byte)))
(assertion-violation 'write-image "io-bytes to not fit evenly into cells"))
(initialize-memory)
(call-with-output-file file
(lambda (port)
(set-port-crlf?! port #f)
(let ((start (transport start-proc)) ; transport the start-proc
(false (transport #f)))
(display id-string port)
(newline port)
(write-page port)
(newline port)
(display architecture-version port)
(newline port)
(display "0" port) ; image format; must be synchronized with
; IMAGE-FORMAT in image-util.scm
(newline port)
(boot-write-number bytes-per-cell port)
(boot-write-number 0 port) ; newspace begin
(boot-write-number (a-units->cells *hp*) port)
(boot-write-number false port) ; symbol table
(boot-write-number false port) ; imported bindings
(boot-write-number false port) ; exported bindings
(boot-write-number false port) ; resumer records
(boot-write-number start port) ; start-proc
(write-page port)
(write-descriptor 1 port) ; endianness indicator
(write-heap port)))) ; write out the heap
)
(define bits-per-io-byte 8) ; for writing images
(define (write-page port)
(write-char (ascii->char 12) port))
(define io-byte-mask
(low-bits -1 bits-per-io-byte))
;(define bits-per-cell -- defined in data.scm
; (* bits-per-byte bytes-per-cell))
(define (big-endian-write-descriptor thing port)
(let loop ((i (- bits-per-cell bits-per-io-byte)))
(cond ((>= i 0)
(write-byte (bitwise-and io-byte-mask
(arithmetic-shift thing (- 0 i))) port)
(loop (- i bits-per-io-byte))))))
(define (little-endian-write-descriptor thing port)
(let loop ((i 0))
(cond ((< i bits-per-cell)
(write-byte (bitwise-and io-byte-mask
(arithmetic-shift thing (- 0 i))) port)
(loop (+ i bits-per-io-byte))))))
(define write-descriptor little-endian-write-descriptor)
;; writing characters as Unicode code points
(define bits-per-scalar-value-unit
(* bits-per-byte bytes-per-scalar-value-unit))
(define (write-scalar-value scalar-value port)
(let loop ((i 0))
(cond ((< i bits-per-scalar-value-unit)
(write-byte (bitwise-and io-byte-mask
(arithmetic-shift scalar-value (- 0 i)))
port)
(loop (+ i bits-per-io-byte))))))
(define (boot-write-number n port)
(display n port)
(newline port))
|