Attachment #132102 for bug #194099

Lines 44-51 Link Here

(-)scheme48-1.3~/configure.in (-1 / +2 lines)
44	define(S48_IEEE_ENDIANNESS, [dnl	44	define(S48_IEEE_ENDIANNESS, [dnl
45	AC_MSG_CHECKING([IEEE floating-point endianness])	45	AC_MSG_CHECKING([IEEE floating-point endianness])
46	AC_TRY_RUN([#include <stdio.h>	46	AC_TRY_RUN([#include <stdio.h>
		47	#include <inttypes.h>
47		48
48	typedef unsigned long word32_t;	49	typedef uint32_t word32_t;
49		50
50	typedef union { double d; word32_t word[2]; } double_overlay;	51	typedef union { double d; word32_t word[2]; } double_overlay;
51		52




   `bignum_digit_type'; deallocation is the responsibility of the
   user (in Scheme, the garbage collector handles this). */
#define BIGNUM_ALLOCATE_TAGGED(length_in_digits)		\
    (s48_allocate_bignum((length_in_digits + 1) *		\
                         sizeof(bignum_digit_type)))
#define BIGNUM_ALLOCATE(length_in_digits)			\
    (S48_ADDRESS_AFTER_HEADER((BIGNUM_ALLOCATE_TAGGED((length_in_digits))), \
			       BIGNUM_ALLOCATE_TAGGED((length_in_digits))), \
			       long))
extern s48_value	s48_allocate_bignum(long size);

/* BIGNUM_TO_POINTER casts a bignum object to a digit array pointer. */
#define BIGNUM_TO_POINTER(bignum) ((bignum_digit_type *) (bignum))

Lines 17-24 Link Here

(-)scheme48-1.3~/c/extension.c (-2 / +2 lines)
17		17
18	#include "scheme48.h"	18	#include "scheme48.h"
19		19
20	#define GREATEST_FIXNUM_VALUE ((1 << 29) - 1)	20	#define GREATEST_FIXNUM_VALUE ((1L << 61) - 1)
21	#define LEAST_FIXNUM_VALUE (-1 << 29)	21	#define LEAST_FIXNUM_VALUE (-1L << 61)
22	#define CHANNEL_INDEX(x) EXTRACT_FIXNUM(STOB_REF(x, 1))	22	#define CHANNEL_INDEX(x) EXTRACT_FIXNUM(STOB_REF(x, 1))
23	#define FOR_INPUT 1	23	#define FOR_INPUT 1
24	#define FOR_OUTPUT 2	24	#define FOR_OUTPUT 2

Lines 24-36 Link Here

(-)scheme48-1.3~/c/free.c (-2 / +4 lines)
24	#include "sysdep.h"	24	#include "sysdep.h"
25	#endif	25	#endif
26		26
27	typedef unsigned long word32_t;	27	#include <inttypes.h>
28		28
		29	typedef uint32_t word32_t;
		30
29	/* It's a shame ... */	31	/* It's a shame ... */
30	#ifdef _WIN32	32	#ifdef _WIN32
31	#define UNSIGNED64 unsigned _int64	33	#define UNSIGNED64 unsigned _int64
32	#else	34	#else
33	#define UNSIGNED64 unsigned long long	35	#define UNSIGNED64 uint64_t
34	#endif	36	#endif
35		37
36	#define U32 word32_t	38	#define U32 word32_t

Lines 42-49 Link Here

(-)scheme48-1.3~/c/scheme48.h.in (-2 / +2 lines)
42	/* Superceded name for the above definition, retained for compatibility. */	42	/* Superceded name for the above definition, retained for compatibility. */
43	#define S48_EQ(v1, v2) ((v1) == (v2))	43	#define S48_EQ(v1, v2) ((v1) == (v2))
44		44
45	#define S48_MAX_FIXNUM_VALUE ((1 << 29) - 1)	45	#define S48_MAX_FIXNUM_VALUE ((1L << 61) - 1)
46	#define S48_MIN_FIXNUM_VALUE (-1 << 29)	46	#define S48_MIN_FIXNUM_VALUE (-1L << 61)
47		47
48	S48_EXTERN int s48_stob_has_type(s48_value, int);	48	S48_EXTERN int s48_stob_has_type(s48_value, int);
49	S48_EXTERN long s48_stob_length(s48_value, int);	49	S48_EXTERN long s48_stob_length(s48_value, int);

Lines 154-160 Link Here

(-)scheme48-1.3~/ps-compiler/prescheme/primop/primop.scm (-1 / +1 lines)
154	; Randomness needed by both arith.scm and c-arith.scm.	154	; Randomness needed by both arith.scm and c-arith.scm.
155		155
156	; What we will get in C.	156	; What we will get in C.
157	(define prescheme-integer-size 32)	157	(define prescheme-integer-size 64)
158		158
159	(define int-mask (- (arithmetic-shift 1 prescheme-integer-size) 1))	159	(define int-mask (- (arithmetic-shift 1 prescheme-integer-size) 1))
160		160




; Essential constants

(define level          17)
(define little-endian? #f)
(define bits-per-byte  8)
(define bytes-per-cell 8)               ; [64-bit]
(define bits-per-cell  (* bits-per-byte bytes-per-cell))
(define addressing-units-per-cell 8)    ; [64-bit]

; This is actually the mimimum for the different PreScheme implementations.
; The Scheme version of PreScheme leaves 30 bits for PreScheme's fixnums.

; USEFUL-BITS-PER-WORD is not written in the image.
(define useful-bits-per-word      30)

(define unused-field-width 3)           ; [64-bit]

(define tag-field-width 2)


					     header-type-field-width))))

(define (make-stob-descriptor addr)
;;   (make-descriptor (enum tag stob) (a-units->cells addr))
  ;++ ick
;;   (make-descriptor (enum tag stob)
;;                    (arithmetic-shift (a-units->cells addr)
;;                                      (- unused-field-width
;;                                         tag-field-width)))
  (+ addr (enum tag stob)))

(define (bytes->cells bytes)
  (quotient (+ bytes (- bytes-per-cell 1))

Lines 131-137 Link Here

(-)scheme48-1.3~/scheme/link/generate-c-header.scm (-1 / +1 lines)
131	(c-define "S48_STOB_HEADER(x) (S48_STOB_REF((x),-1))")	131	(c-define "S48_STOB_HEADER(x) (S48_STOB_REF((x),-1))")
132	(c-define "S48_STOB_ADDRESS(x) (&(S48_STOB_HEADER(x)))")	132	(c-define "S48_STOB_ADDRESS(x) (&(S48_STOB_HEADER(x)))")
133	(c-define "S48_STOB_BYTE_LENGTH(x) (S48_STOB_HEADER(x) >> 8)")	133	(c-define "S48_STOB_BYTE_LENGTH(x) (S48_STOB_HEADER(x) >> 8)")
134	(c-define "S48_STOB_DESCRIPTOR_LENGTH(x) (S48_STOB_HEADER(x) >> 10)")	134	(c-define "S48_STOB_DESCRIPTOR_LENGTH(x) (S48_STOB_HEADER(x) >> 11)")
135	(c-define "S48_STOB_IMMUTABLEP(x) ((S48_STOB_HEADER(x)>>7) & 1)")	135	(c-define "S48_STOB_IMMUTABLEP(x) ((S48_STOB_HEADER(x)>>7) & 1)")
136	(c-define "S48_STOB_MAKE_IMMUTABLE(x) ((S48_STOB_HEADER(x)) \|= (1<<7))")	136	(c-define "S48_STOB_MAKE_IMMUTABLE(x) ((S48_STOB_HEADER(x)) \|= (1<<7))")
137	(newline)	137	(newline)




  (let ((address (address-index address)))
    (let ((vector (address->vector address))
	  (byte-address (address->vector-index address)))
      (if (not (= 0 (bitwise-and byte-address 5))) ; [64-bit]
	  (error "unaligned address error" address)
          (+ (arithmetic-shift (signed-code-vector-ref vector byte-address) 56)
             (arithmetic-shift (code-vector-ref vector (+ byte-address 1))  48)
             (arithmetic-shift (code-vector-ref vector (+ byte-address 2))  40)
             (arithmetic-shift (code-vector-ref vector (+ byte-address 3))  32)
             (arithmetic-shift (code-vector-ref vector (+ byte-address 4))  24)
             (arithmetic-shift (code-vector-ref vector (+ byte-address 5))  16)
             (arithmetic-shift (code-vector-ref vector (+ byte-address 6))   8)
                               (code-vector-ref vector (+ byte-address 7)))))))
  
(define (unsigned-byte-set! address value)
  (let ((address (address-index address)))

      (if (not (= 0 (bitwise-and byte-address 3)))
	  (error "unaligned address error" address))
      (code-vector-set! vector    byte-address
                        (bitwise-and 255 (arithmetic-shift value -56)))
      (code-vector-set! vector (+ byte-address 1)
                        (bitwise-and 255 (arithmetic-shift value -48)))
      (code-vector-set! vector (+ byte-address 2)
                        (bitwise-and 255 (arithmetic-shift value -40)))
      (code-vector-set! vector (+ byte-address 3)
                        (bitwise-and 255 (arithmetic-shift value -32)))
      (code-vector-set! vector (+ byte-address 4)
			(bitwise-and 255 (arithmetic-shift value -24)))
      (code-vector-set! vector (+ byte-address 5)
			(bitwise-and 255 (arithmetic-shift value -16)))
      (code-vector-set! vector (+ byte-address 6)
			(bitwise-and 255 (arithmetic-shift value -8)))
      (code-vector-set! vector (+ byte-address 7)
			(bitwise-and 255 value)))))

; With the right access to the flonum bits we could actually make these

	   (let ((vector (address->vector address))
		 (byte-address (address->vector-index address)))
	     (let loop ((i 0))
	       (if (= i count)
		       (not (byte-ready? port)))
		   (values i #f (enum errors no-errors))
		     (cond ((eof-object? b)
			    (values i #t (enum errors no-errors)))
			   (else
			    (code-vector-set! vector
					      (+ i byte-address)

Lines 21-27 Link Here

(-)scheme48-1.3~/scheme/prescheme/package-defs.scm (-1 / +1 lines)
21	(optimize auto-integrate)	21	(optimize auto-integrate)
22	(begin	22	(begin
23	; What we will get in C on many machines	23	; What we will get in C on many machines
24	(define pre-scheme-integer-size 32))	24	(define pre-scheme-integer-size 64)) ; [64-bit]
25	(files ps-defenum prescheme memory))	25	(files ps-defenum prescheme memory))
26		26
27	(define-structure ps-record-types (export define-record-type)	27	(define-structure ps-record-types (export define-record-type)

Lines 36-41 Link Here

(-)scheme48-1.3~/scheme/vm/interfaces.scm (+1 lines)
36	address-after-header	36	address-after-header
37	stob-header stob-header-set!	37	stob-header stob-header-set!
38	stob-overhead	38	stob-overhead
		39	reverse-descriptor-byte-order!
39	))	40	))
40		41
41	; Low-level data structures	42	; Low-level data structures

Lines 547-553 Link Here

(-)scheme48-1.3~/scheme/vm/package-defs.scm (-1 / +2 lines)
547	(files (arith bignum-arith)))	547	(files (arith bignum-arith)))
548		548
549	(define-structure integer-arithmetic integer-arithmetic-interface	549	(define-structure integer-arithmetic integer-arithmetic-interface
550	(open prescheme	550	(open prescheme
		551	system-spec
551	fixnum-arithmetic	552	fixnum-arithmetic
552	bignum-arithmetic	553	bignum-arithmetic
553	external	554	external

Lines 111-116 Link Here

(-)scheme48-1.3~/scheme/vm/ps-package-defs.scm (-1 / +1 lines)
111	(define-structures ((system-spec (export useful-bits-per-word)))	111	(define-structures ((system-spec (export useful-bits-per-word)))
112	(open prescheme)	112	(open prescheme)
113	(begin	113	(begin
114	(define useful-bits-per-word 32) ; when compiled	114	(define useful-bits-per-word 64) ; when compiled [64-bit]
115	))	115	))
116		116

Lines 17-23 Link Here

(-)scheme48-1.3~/scheme/vm/arith/bignum-low.scm (-1 / +1 lines)
17	(define (bignum-digits->size n)	17	(define (bignum-digits->size n)
18	(bignum-size (cells->bytes (+ n 1))))	18	(bignum-size (cells->bytes (+ n 1))))
19		19
20	(define bignum-digit-bits 30) ; BIGNUM_DIGIT_LENGTH in bignumint.h	20	(define bignum-digit-bits 62) ; BIGNUM_DIGIT_LENGTH in bignumint.h
21		21
22	(define (bignum-bits-to-digits n)	22	(define (bignum-bits-to-digits n)
23	(quotient (+ n (- bignum-digit-bits 1))	23	(quotient (+ n (- bignum-digit-bits 1))

Lines 67-70 Link Here

(-)scheme48-1.3~/scheme/vm/arith/integer.scm (-1 / +1 lines)
67	(long->bignum x key)	67	(long->bignum x key)
68	(enter-fixnum x)))	68	(enter-fixnum x)))
69		69
70	(define long-as-integer-size (bignum-bits-to-size 32))	70	(define long-as-integer-size (bignum-bits-to-size useful-bits-per-word))




; Fundamental parameters

(define bits-per-byte 8)
(define bytes-per-cell 8)               ; [64-bit]
(define bits-per-cell (* bits-per-byte bytes-per-cell))

(define (bytes->cells bytes)

  ; using shift instead of quotient for speed
  ; (quotient (+ bytes (- bytes-per-cell 1)) bytes-per-cell)
  (arithmetic-shift-right (+ bytes (- bytes-per-cell 1))
			  3))  ; log(bytes-per-cell) [64-bit]

(define (cells->bytes cells)
  (* cells bytes-per-cell))

;  number of "unused bits" at its low end.  On a byte-addressable machine with
;  32 bit addresses, there are two.

(define unused-field-width 3)           ; [64-bit]

(define addressing-units-per-cell 8)    ; [64-bit]

(define (cells->a-units cells)
  (adjoin-bits cells 0 unused-field-width))

(define (unsigned-descriptor-data descriptor)
  (unsigned-high-bits descriptor tag-field-width))

(define (set-descriptor-tag proto-descriptor tag)
  (assert (= 0 (descriptor-tag proto-descriptor)))
  (+ proto-descriptor tag))

(define vm-eq? =)

; The four tags are: fixnum, immediate (character, boolean, etc.),

;  cell number of the first cell after the object's header cell.

(define (add-stob-tag address-as-integer)
  (+ address-as-integer (enum tag stob)))

(define (remove-stob-tag stob)
  (- stob (enum tag stob)))




	   (if (not (= *memory-end* 0))
	       (deallocate-memory *memory*))
           (set! *memory* (allocate-memory size))
	   (if (null-address? *memory*)
	       (error "out of memory, unable to continue"))
	   (set! *memory-begin* *memory*)
           (set! *memory-end* (+ *memory* size))))))


(define (stob-header-set! stob header)
  (store! (address-at-header stob) header))

(define (reverse-descriptor-byte-order! address)
  (do ((i 0 (+ i 1))
       (j (- bytes-per-cell 1) (- j 1)))
      ((>= i j))
    (let ((addr-a (address+ address i))
          (addr-b (address+ address j)))
      (let ((byte-a (fetch-byte addr-a))
            (byte-b (fetch-byte addr-b)))
        (store-byte! addr-a byte-b)
        (store-byte! addr-b byte-a)))))




	(unspecific)))
  -1)

; ABCD => DCBA

; memory intensive, but independent of Scheme's integer size

(define (reverse-descriptor-byte-order! addr)
  (let ((x (fetch-byte addr)))
    (store-byte! addr (fetch-byte (address+ addr 3)))
    (store-byte! (address+ addr 3) x))
  (let ((x (fetch-byte (address+ addr 1))))
    (store-byte! (address+ addr 1) (fetch-byte (address+ addr 2)))
    (store-byte! (address+ addr 2) x)))

(define (s48-reverse-byte-order! start end)
  (error-message "Correcting byte order of resumed image.")
  (let loop ((ptr start))

Return to bug 194099

Lines 224-241 Link Here

(-)scheme48-1.3~/scheme/vm/heap/read-image.scm (-12 lines)
224	(unspecific)))	224	(unspecific)))
225	-1)	225	-1)
226		226
227	; ABCD => DCBA
228
229	; memory intensive, but independent of Scheme's integer size
230
231	(define (reverse-descriptor-byte-order! addr)
232	(let ((x (fetch-byte addr)))
233	(store-byte! addr (fetch-byte (address+ addr 3)))
234	(store-byte! (address+ addr 3) x))
235	(let ((x (fetch-byte (address+ addr 1))))
236	(store-byte! (address+ addr 1) (fetch-byte (address+ addr 2)))
237	(store-byte! (address+ addr 2) x)))
238
239	(define (s48-reverse-byte-order! start end)	227	(define (s48-reverse-byte-order! start end)
240	(error-message "Correcting byte order of resumed image.")	228	(error-message "Correcting byte order of resumed image.")
241	(let loop ((ptr start))	229	(let loop ((ptr start))

Lines 52-64 Link Here

(-)scheme48-1.3~/c/bignumint.h (-5 / +4 lines)
52	`bignum_digit_type'; deallocation is the responsibility of the	52	`bignum_digit_type'; deallocation is the responsibility of the
53	user (in Scheme, the garbage collector handles this). */	53	user (in Scheme, the garbage collector handles this). */
54	#define BIGNUM_ALLOCATE_TAGGED(length_in_digits) \	54	#define BIGNUM_ALLOCATE_TAGGED(length_in_digits) \
55	((long ) s48_allocate_bignum((length_in_digits + 1) \	55	(s48_allocate_bignum((length_in_digits + 1) * \
56	sizeof(bignum_digit_type)))	56	sizeof(bignum_digit_type)))
57	#define BIGNUM_ALLOCATE(length_in_digits) \	57	#define BIGNUM_ALLOCATE(length_in_digits) \
58	(S48_ADDRESS_AFTER_HEADER(((char *) \	58	(S48_ADDRESS_AFTER_HEADER((BIGNUM_ALLOCATE_TAGGED((length_in_digits))), \
59	BIGNUM_ALLOCATE_TAGGED((length_in_digits))), \
60	long))	59	long))
61	extern char * s48_allocate_bignum(long size);	60	extern s48_value s48_allocate_bignum(long size);
62		61
63	/* BIGNUM_TO_POINTER casts a bignum object to a digit array pointer. */	62	/* BIGNUM_TO_POINTER casts a bignum object to a digit array pointer. */
64	#define BIGNUM_TO_POINTER(bignum) ((bignum_digit_type *) (bignum))	63	#define BIGNUM_TO_POINTER(bignum) ((bignum_digit_type *) (bignum))

Lines 20-30 Link Here

(-)scheme48-1.3~/scheme/link/data.scm (-5 / +11 lines)
20	; Essential constants	20	; Essential constants
21		21
22	(define level 17)	22	(define level 17)
23	(define little-endian? #t)	23	(define little-endian? #f)
24	(define bits-per-byte 8)	24	(define bits-per-byte 8)
25	(define bytes-per-cell 4)	25	(define bytes-per-cell 8) ; [64-bit]
26	(define bits-per-cell (* bits-per-byte bytes-per-cell))	26	(define bits-per-cell (* bits-per-byte bytes-per-cell))
27	(define addressing-units-per-cell 4)	27	(define addressing-units-per-cell 8) ; [64-bit]
28		28
29	; This is actually the mimimum for the different PreScheme implementations.	29	; This is actually the mimimum for the different PreScheme implementations.
30	; The Scheme version of PreScheme leaves 30 bits for PreScheme's fixnums.	30	; The Scheme version of PreScheme leaves 30 bits for PreScheme's fixnums.
Lines 32-38 Link Here
32	; USEFUL-BITS-PER-WORD is not written in the image.	32	; USEFUL-BITS-PER-WORD is not written in the image.
33	(define useful-bits-per-word 30)	33	(define useful-bits-per-word 30)
34		34
35	(define unused-field-width 2)	35	(define unused-field-width 3) ; [64-bit]
36		36
37	(define tag-field-width 2)	37	(define tag-field-width 2)
38		38
Lines 119-125 Link Here
119	header-type-field-width))))	119	header-type-field-width))))
120		120
121	(define (make-stob-descriptor addr)	121	(define (make-stob-descriptor addr)
122	(make-descriptor (enum tag stob) (a-units->cells addr)))	122	;; (make-descriptor (enum tag stob) (a-units->cells addr))
		123	;++ ick
		124	;; (make-descriptor (enum tag stob)
		125	;; (arithmetic-shift (a-units->cells addr)
		126	;; (- unused-field-width
		127	;; tag-field-width)))
		128	(+ addr (enum tag stob)))
123		129
124	(define (bytes->cells bytes)	130	(define (bytes->cells bytes)
125	(quotient (+ bytes (- bytes-per-cell 1))	131	(quotient (+ bytes (- bytes-per-cell 1))

Lines 129-140 Link Here

(-)scheme48-1.3~/scheme/prescheme/memory.scm (-11 / +22 lines)
129	(let ((address (address-index address)))	129	(let ((address (address-index address)))
130	(let ((vector (address->vector address))	130	(let ((vector (address->vector address))
131	(byte-address (address->vector-index address)))	131	(byte-address (address->vector-index address)))
132	(if (not (= 0 (bitwise-and byte-address 3)))	132	(if (not (= 0 (bitwise-and byte-address 5))) ; [64-bit]
133	(error "unaligned address error" address)	133	(error "unaligned address error" address)
134	(+ (+ (arithmetic-shift (signed-code-vector-ref vector byte-address) 24)	134	(+ (arithmetic-shift (signed-code-vector-ref vector byte-address) 56)
135	(arithmetic-shift (code-vector-ref vector (+ byte-address 1)) 16))	135	(arithmetic-shift (code-vector-ref vector (+ byte-address 1)) 48)
136	(+ (arithmetic-shift (code-vector-ref vector (+ byte-address 2)) 8)	136	(arithmetic-shift (code-vector-ref vector (+ byte-address 2)) 40)
137	(code-vector-ref vector (+ byte-address 3))))))))	137	(arithmetic-shift (code-vector-ref vector (+ byte-address 3)) 32)
		138	(arithmetic-shift (code-vector-ref vector (+ byte-address 4)) 24)
		139	(arithmetic-shift (code-vector-ref vector (+ byte-address 5)) 16)
		140	(arithmetic-shift (code-vector-ref vector (+ byte-address 6)) 8)
		141	(code-vector-ref vector (+ byte-address 7)))))))
138		142
139	(define (unsigned-byte-set! address value)	143	(define (unsigned-byte-set! address value)
140	(let ((address (address-index address)))	144	(let ((address (address-index address)))
Lines 149-160 Link Here
149	(if (not (= 0 (bitwise-and byte-address 3)))	153	(if (not (= 0 (bitwise-and byte-address 3)))
150	(error "unaligned address error" address))	154	(error "unaligned address error" address))
151	(code-vector-set! vector byte-address	155	(code-vector-set! vector byte-address
152	(bitwise-and 255 (arithmetic-shift value -24)))	156	(bitwise-and 255 (arithmetic-shift value -56)))
153	(code-vector-set! vector (+ byte-address 1)	157	(code-vector-set! vector (+ byte-address 1)
154	(bitwise-and 255 (arithmetic-shift value -16)))	158	(bitwise-and 255 (arithmetic-shift value -48)))
155	(code-vector-set! vector (+ byte-address 2)	159	(code-vector-set! vector (+ byte-address 2)
156	(bitwise-and 255 (arithmetic-shift value -8)))	160	(bitwise-and 255 (arithmetic-shift value -40)))
157	(code-vector-set! vector (+ byte-address 3)	161	(code-vector-set! vector (+ byte-address 3)
		162	(bitwise-and 255 (arithmetic-shift value -32)))
		163	(code-vector-set! vector (+ byte-address 4)
		164	(bitwise-and 255 (arithmetic-shift value -24)))
		165	(code-vector-set! vector (+ byte-address 5)
		166	(bitwise-and 255 (arithmetic-shift value -16)))
		167	(code-vector-set! vector (+ byte-address 6)
		168	(bitwise-and 255 (arithmetic-shift value -8)))
		169	(code-vector-set! vector (+ byte-address 7)
158	(bitwise-and 255 value)))))	170	(bitwise-and 255 value)))))
159		171
160	; With the right access to the flonum bits we could actually make these	172	; With the right access to the flonum bits we could actually make these
Lines 190-201 Link Here
190	(let ((vector (address->vector address))	202	(let ((vector (address->vector address))
191	(byte-address (address->vector-index address)))	203	(byte-address (address->vector-index address)))
192	(let loop ((i 0))	204	(let loop ((i 0))
193	(if (or (= i count)	205	(if (= i count)
194	(not (byte-ready? port)))
195	(values i #f (enum errors no-errors))	206	(values i #f (enum errors no-errors))
196	(cond ((eof-object? b)	207	(cond ((eof-object? b)
197	(values i #f (enum errors no-errors)))	208	(values i #t (enum errors no-errors)))
198	(else	209	(else
199	(code-vector-set! vector	210	(code-vector-set! vector
200	(+ i byte-address)	211	(+ i byte-address)

Lines 13-19 Link Here

(-)scheme48-1.3~/scheme/vm/data/data.scm (-9 / +5 lines)
13	; Fundamental parameters	13	; Fundamental parameters
14		14
15	(define bits-per-byte 8)	15	(define bits-per-byte 8)
16	(define bytes-per-cell 4)	16	(define bytes-per-cell 8) ; [64-bit]
17	(define bits-per-cell (* bits-per-byte bytes-per-cell))	17	(define bits-per-cell (* bits-per-byte bytes-per-cell))
18		18
19	(define (bytes->cells bytes)	19	(define (bytes->cells bytes)
Lines 20-26 Link Here
20	; using shift instead of quotient for speed	20	; using shift instead of quotient for speed
21	; (quotient (+ bytes (- bytes-per-cell 1)) bytes-per-cell)	21	; (quotient (+ bytes (- bytes-per-cell 1)) bytes-per-cell)
22	(arithmetic-shift-right (+ bytes (- bytes-per-cell 1))	22	(arithmetic-shift-right (+ bytes (- bytes-per-cell 1))
23	2)) ; log(bytes-per-cell)	23	3)) ; log(bytes-per-cell) [64-bit]
24		24
25	(define (cells->bytes cells)	25	(define (cells->bytes cells)
26	(* cells bytes-per-cell))	26	(* cells bytes-per-cell))
Lines 40-48 Link Here
40	; number of "unused bits" at its low end. On a byte-addressable machine with	40	; number of "unused bits" at its low end. On a byte-addressable machine with
41	; 32 bit addresses, there are two.	41	; 32 bit addresses, there are two.
42		42
43	(define unused-field-width 2)	43	(define unused-field-width 3) ; [64-bit]
44		44
45	(define addressing-units-per-cell 4)	45	(define addressing-units-per-cell 8) ; [64-bit]
46		46
47	(define (cells->a-units cells)	47	(define (cells->a-units cells)
48	(adjoin-bits cells 0 unused-field-width))	48	(adjoin-bits cells 0 unused-field-width))
Lines 74-83 Link Here
74	(define (unsigned-descriptor-data descriptor)	74	(define (unsigned-descriptor-data descriptor)
75	(unsigned-high-bits descriptor tag-field-width))	75	(unsigned-high-bits descriptor tag-field-width))
76		76
77	(define (set-descriptor-tag proto-descriptor tag)
78	(assert (= 0 (descriptor-tag proto-descriptor)))
79	(+ proto-descriptor tag))
80
81	(define vm-eq? =)	77	(define vm-eq? =)
82		78
83	; The four tags are: fixnum, immediate (character, boolean, etc.),	79	; The four tags are: fixnum, immediate (character, boolean, etc.),
Lines 294-300 Link Here
294	; cell number of the first cell after the object's header cell.	290	; cell number of the first cell after the object's header cell.
295		291
296	(define (add-stob-tag address-as-integer)	292	(define (add-stob-tag address-as-integer)
297	(set-descriptor-tag address-as-integer (enum tag stob)))	293	(+ address-as-integer (enum tag stob)))
298		294
299	(define (remove-stob-tag stob)	295	(define (remove-stob-tag stob)
300	(- stob (enum tag stob)))	296	(- stob (enum tag stob)))

Lines 26-32 Link Here

(-)scheme48-1.3~/scheme/vm/data/memory.scm (-1 / +12 lines)
26	(if (not (= memory-end 0))	26	(if (not (= memory-end 0))
27	(deallocate-memory memory))	27	(deallocate-memory memory))
28	(set! memory (allocate-memory size))	28	(set! memory (allocate-memory size))
29	(if (= -1 memory)	29	(if (null-address? memory)
30	(error "out of memory, unable to continue"))	30	(error "out of memory, unable to continue"))
31	(set! memory-begin memory)	31	(set! memory-begin memory)
32	(set! memory-end (+ memory size))))))	32	(set! memory-end (+ memory size))))))
Lines 61-63 Link Here
61		61
62	(define (stob-header-set! stob header)	62	(define (stob-header-set! stob header)
63	(store! (address-at-header stob) header))	63	(store! (address-at-header stob) header))
		64
		65	(define (reverse-descriptor-byte-order! address)
		66	(do ((i 0 (+ i 1))
		67	(j (- bytes-per-cell 1) (- j 1)))
		68	((>= i j))
		69	(let ((addr-a (address+ address i))
		70	(addr-b (address+ address j)))
		71	(let ((byte-a (fetch-byte addr-a))
		72	(byte-b (fetch-byte addr-b)))
		73	(store-byte! addr-a byte-b)
		74	(store-byte! addr-b byte-a)))))