From: Chris Hanson Date: Wed, 20 Sep 1989 15:05:47 +0000 (+0000) Subject: Eliminate dependency on return value of modifier. X-Git-Tag: 20090517-FFI~11795 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=24b372d2a14f5761c3597577a3aeae3103dfa0af;p=mit-scheme.git Eliminate dependency on return value of modifier. --- diff --git a/v7/src/runtime/hash.scm b/v7/src/runtime/hash.scm index 47640243d..4db6dd5bd 100644 --- a/v7/src/runtime/hash.scm +++ b/v7/src/runtime/hash.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/hash.scm,v 14.1 1988/06/13 11:45:38 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/hash.scm,v 14.2 1989/09/20 15:04:15 cph Rel $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -87,25 +87,22 @@ MIT in each case. |# ;;; locked against garbage collection. (define (initialize-package!) - (set! smallest-positive-bignum - (let loop ((x 1) (y 2)) - (if (object-type? (object-type x) y) - (loop y (* y 2)) - (* y 2)))) (set! next-hash-number 1) (set! hash-table-size default/hash-table-size) (set! unhash-table (make-vector hash-table-size '())) (set! hash-table (make-vector (1+ hash-table-size) '())) ;; Could use `primitive-object-set!' to clobber the manifest type ;; code instead of allocating another word here. - (vector-set! hash-table 0 + (vector-set! hash-table + 0 ((ucode-primitive primitive-object-set-type) (ucode-type manifest-special-nm-vector) (make-non-pointer-object hash-table-size))) (let loop ((n 0)) (if (< n hash-table-size) - (begin (vector-set! unhash-table n (cons true '())) - (loop (1+ n))))) + (begin + (vector-set! unhash-table n (cons true '())) + (loop (1+ n))))) (add-event-receiver! event:after-restore (lambda () (gc-flip))) (add-gc-daemon! rehash-gc-daemon)) @@ -114,7 +111,6 @@ MIT in each case. |# (define hash-table-size) (define unhash-table) (define hash-table) -(define smallest-positive-bignum) (define (hash x) (if (eq? x false) @@ -188,39 +184,50 @@ MIT in each case. |# ;;; is SNM rather than NM to make the buckets be relocated at band ;;; load/restore time. +;;; **** There is also a problem with intermediate bignums being +;;; consed by `rehash' while computing `index'. This must be fixed +;;; before the Scheme code below can be used. **** + ;;; Until this code is compiled, and therefore safe, it is replaced by ;;; a primitive. See the installation code below. - #| (define (rehash-gc-daemon) (let cleanup ((n hash-table-size)) (if (not (zero? n)) - (begin (vector-set! hash-table n '()) - (cleanup (-1+ n))))) + (begin + (vector-set! hash-table n '()) + (cleanup (-1+ n))))) (let outer ((n (-1+ hash-table-size))) - (if (negative? n) - true + (if (not (negative? n)) (let ((bucket (vector-ref unhash-table n))) (if (car bucket) (let inner1 ((l1 bucket) (l2 (cdr bucket))) - (cond ((null? l2) (outer (-1+ n))) + (cond ((null? l2) + (outer (-1+ n))) ((eq? (system-pair-car (car l2)) false) (set-cdr! l1 (cdr l2)) (inner1 l1 (cdr l1))) - (else (rehash (car l2)) - (inner1 l2 (cdr l2))))) + (else + (rehash (car l2)) + (inner1 l2 (cdr l2))))) (let inner2 ((l (cdr bucket))) - (cond ((null? l) (outer (-1+ n))) + (cond ((null? l) + (outer (-1+ n))) ((eq? (system-pair-car (car l)) false) (inner2 (cdr l))) - (else (rehash (car l)) - (inner2 (cdr l)))))))))) + (else + (rehash (car l)) + (inner2 (cdr l)))))))))) (define (rehash weak-pair) - (let ((index (1+ (modulo (object-datum (system-pair-car weak-pair)) - hash-table-size)))) + (let ((index + (1+ (modulo (object-datum (system-pair-car weak-pair)) + hash-table-size)))) (vector-set! hash-table index (cons (object-new-type (ucode-type pair) weak-pair) - (vector-ref hash-table index))))) + (vector-ref hash-table index))) + unspecific)) |# +(define (rehash-gc-daemon) + ((ucode-primitive rehash) unhash-table hash-table)) \ No newline at end of file diff --git a/v7/src/runtime/io.scm b/v7/src/runtime/io.scm index 7e15267ea..2e48b8a03 100644 --- a/v7/src/runtime/io.scm +++ b/v7/src/runtime/io.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/io.scm,v 14.2 1989/06/09 16:51:31 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/io.scm,v 14.3 1989/09/20 15:03:59 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -113,12 +113,13 @@ MIT in each case. |# (fluid-let ((traversing? true)) (without-interrupts (lambda () - (if (eq? closed-direction - (set-channel-direction! channel closed-direction)) + (if (eq? closed-direction (channel-direction channel)) true ;Already closed! (begin - (file-close-channel - (set-channel-descriptor! channel closed-descriptor)) (let loop + (file-close-channel (channel-descriptor channel)) + (set-channel-direction! channel closed-direction) + (set-channel-descriptor! channel closed-descriptor) + (let loop ((l1 open-files-list) (l2 (cdr open-files-list))) (cond ((null? l2) diff --git a/v7/src/runtime/list.scm b/v7/src/runtime/list.scm index 6ae2dc4fb..d30d068aa 100644 --- a/v7/src/runtime/list.scm +++ b/v7/src/runtime/list.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/list.scm,v 14.8 1989/08/17 07:50:55 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/list.scm,v 14.9 1989/09/20 15:05:47 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -171,15 +171,13 @@ MIT in each case. |# car))) (define-integrable (weak-set-car! weak-pair object) - (system-pair-set-car! weak-pair (or object weak-pair/false)) - unspecific) + (system-pair-set-car! weak-pair (or object weak-pair/false))) (define-integrable (weak-cdr weak-pair) (system-pair-cdr weak-pair)) (define-integrable (weak-set-cdr! weak-pair object) - (system-pair-set-cdr! weak-pair object) - unspecific) + (system-pair-set-cdr! weak-pair object)) (define (weak-memq object weak-list) (let ((object (if object object weak-pair/false))) @@ -330,7 +328,9 @@ MIT in each case. |# (define (reverse! l) (let loop ((current l) (new-cdr '())) (if (pair? current) - (loop (set-cdr! current new-cdr) current) + (let ((next (cdr current))) + (set-cdr! current new-cdr) + (loop next current)) (begin (if (not (null? current)) (error "REVERSE!: Argument not a list" l))