From: Chris Hanson Date: Mon, 10 Mar 2003 20:53:51 +0000 (+0000) Subject: Eliminate incorrect usage of default initializers in DEFINE-STRUCTURE. X-Git-Tag: 20090517-FFI~1968 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=a8b2424c0254929aa917bb29911d253eb13eb91c;p=mit-scheme.git Eliminate incorrect usage of default initializers in DEFINE-STRUCTURE. These initializers contain variable references that are intended to refer to other slots in the structure. The correct usage assumes that the initializers are closed in the environment in which the DEFINE-STRUCTURE form appears. --- diff --git a/v7/src/compiler/fgopt/reord.scm b/v7/src/compiler/fgopt/reord.scm index 2f586e0af..eb269dc77 100644 --- a/v7/src/compiler/fgopt/reord.scm +++ b/v7/src/compiler/fgopt/reord.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: reord.scm,v 1.4 2003/02/14 18:28:01 cph Exp $ +$Id: reord.scm,v 1.5 2003/03/10 20:51:48 cph Exp $ -Copyright (c) 1988, 1999 Massachusetts Institute of Technology +Copyright 1988,2003 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -66,12 +66,7 @@ number of assignments of any ordering. ;;;; Graph Abstraction -(define-structure (node - (constructor make-node - (target - value - original-dependencies - original-dependents))) +(define-structure (node (constructor %make-node)) ;; An assignment representing a target variable (or static link) and ;; an expression which will be assigned to the target. (target false read-only true) @@ -86,8 +81,16 @@ number of assignments of any ordering. original-dependents ;; Copies of the above; modified during the reordering algorithm. - (dependencies (list-copy original-dependencies)) - (dependents (list-copy original-dependents))) + dependencies + dependents) + +(define (make-node target value original-dependencies original-dependents) + (%make-node target + value + original-dependencies + original-dependents + (list-copy original-dependencies) + (list-copy original-dependents))) (define (make-node-set targets values dependency-sets) (map (lambda (target value dependencies) diff --git a/v7/src/compiler/machines/C/decls.scm b/v7/src/compiler/machines/C/decls.scm index 2b521c83d..dbf2bb927 100644 --- a/v7/src/compiler/machines/C/decls.scm +++ b/v7/src/compiler/machines/C/decls.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: decls.scm,v 1.8 2003/02/14 18:28:02 cph Exp $ +$Id: decls.scm,v 1.9 2003/03/10 20:51:49 cph Exp $ -Copyright (c) 1992-1999, 2001 Massachusetts Institute of Technology +Copyright 1993,2001,2003 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -82,19 +82,22 @@ USA. (define-structure (source-node (conc-name source-node/) - (constructor make/source-node (filename))) - (filename false read-only true) - (pathname (->pathname filename) read-only true) + (constructor %make/source-node (filename pathname))) + (filename #f read-only #t) + (pathname #f read-only #t) (forward-links '()) (backward-links '()) (forward-closure '()) (backward-closure '()) (dependencies '()) (dependents '()) - (rank false) - (syntax-table false) + (rank #f) + (syntax-table #f) (declarations '()) - (modification-time false)) + (modification-time #f)) + +(define (make/source-node filename) + (%make/source-node filename (->pathname filename))) (define (filename->source-node filename) (let ((node (hash-table/get source-hash filename #f))) @@ -216,7 +219,7 @@ USA. (write-string " newer than dependency ") (write (source-node/filename node*)))) newer?)))) - (set-source-node/modification-time! node false)))) + (set-source-node/modification-time! node #f)))) source-nodes) (for-each (lambda (node) @@ -228,7 +231,7 @@ USA. (write (source-node/filename node*)) (write-string " depends on ") (write (source-node/filename node)))) - (set-source-node/modification-time! node* false)) + (set-source-node/modification-time! node* #f)) (source-node/forward-closure node)))) source-nodes))) (for-each (lambda (node) @@ -257,7 +260,7 @@ USA. (define (source-node/touch! node) (with-values (lambda () - (sf/pathname-defaulting (source-node/pathname node) "" false)) + (sf/pathname-defaulting (source-node/pathname node) "" #f)) (lambda (input-pathname bin-pathname spec-pathname) input-pathname (pathname-touch! bin-pathname) @@ -285,7 +288,7 @@ USA. (define (source-node/syntax! node) (with-values (lambda () - (sf/pathname-defaulting (source-node/pathname node) "" false)) + (sf/pathname-defaulting (source-node/pathname node) "" #f)) (lambda (input-pathname bin-pathname spec-pathname) (sf/internal input-pathname bin-pathname spec-pathname @@ -538,15 +541,15 @@ USA. `(INTEGRATE-EXTERNAL ,@(map (let ((default (make-pathname - false - false + #f + #f (cons 'RELATIVE (make-list (length (cdr (pathname-directory pathname))) 'UP)) - false - false - false))) + #f + #f + #f))) (lambda (pathname) (merge-pathnames pathname default))) integration-dependencies))) diff --git a/v7/src/compiler/machines/alpha/decls.scm b/v7/src/compiler/machines/alpha/decls.scm index 5ce6a56ef..35c398689 100644 --- a/v7/src/compiler/machines/alpha/decls.scm +++ b/v7/src/compiler/machines/alpha/decls.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: decls.scm,v 1.10 2003/02/14 18:28:02 cph Exp $ +$Id: decls.scm,v 1.11 2003/03/10 20:51:49 cph Exp $ -Copyright (c) 1992-1999, 2001 Massachusetts Institute of Technology +Copyright 1992,1993,2001,2003 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -82,19 +82,22 @@ USA. (define-structure (source-node (conc-name source-node/) - (constructor make/source-node (filename))) - (filename false read-only true) - (pathname (->pathname filename) read-only true) + (constructor %make/source-node (filename pathname))) + (filename #f read-only #t) + (pathname #f read-only #t) (forward-links '()) (backward-links '()) (forward-closure '()) (backward-closure '()) (dependencies '()) (dependents '()) - (rank false) - (syntax-table false) + (rank #f) + (syntax-table #f) (declarations '()) - (modification-time false)) + (modification-time #f)) + +(define (make/source-node filename) + (%make/source-node filename (->pathname filename))) (define (filename->source-node filename) (let ((node (hash-table/get source-hash filename #f))) @@ -216,7 +219,7 @@ USA. (write-string " newer than dependency ") (write (source-node/filename node*)))) newer?)))) - (set-source-node/modification-time! node false)))) + (set-source-node/modification-time! node #f)))) source-nodes) (for-each (lambda (node) @@ -228,7 +231,7 @@ USA. (write (source-node/filename node*)) (write-string " depends on ") (write (source-node/filename node)))) - (set-source-node/modification-time! node* false)) + (set-source-node/modification-time! node* #f)) (source-node/forward-closure node)))) source-nodes))) (for-each (lambda (node) @@ -257,7 +260,7 @@ USA. (define (source-node/touch! node) (with-values (lambda () - (sf/pathname-defaulting (source-node/pathname node) "" false)) + (sf/pathname-defaulting (source-node/pathname node) "" #f)) (lambda (input-pathname bin-pathname spec-pathname) input-pathname (pathname-touch! bin-pathname) @@ -285,7 +288,7 @@ USA. (define (source-node/syntax! node) (with-values (lambda () - (sf/pathname-defaulting (source-node/pathname node) "" false)) + (sf/pathname-defaulting (source-node/pathname node) "" #f)) (lambda (input-pathname bin-pathname spec-pathname) (sf/internal input-pathname bin-pathname spec-pathname @@ -557,15 +560,15 @@ USA. `(INTEGRATE-EXTERNAL ,@(map (let ((default (make-pathname - false - false + #f + #f (cons 'RELATIVE (make-list (length (cdr (pathname-directory pathname))) 'UP)) - false - false - false))) + #f + #f + #f))) (lambda (pathname) (merge-pathnames pathname default))) integration-dependencies))) diff --git a/v7/src/compiler/machines/bobcat/decls.scm b/v7/src/compiler/machines/bobcat/decls.scm index 505b31d8f..d16469c6a 100644 --- a/v7/src/compiler/machines/bobcat/decls.scm +++ b/v7/src/compiler/machines/bobcat/decls.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Id: decls.scm,v 4.41 2003/02/14 18:28:02 cph Exp $ +$Id: decls.scm,v 4.42 2003/03/10 20:51:49 cph Exp $ -Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology +Copyright 1987,1988,1989,1990,1991,1992 Massachusetts Institute of Technology +Copyright 1993,2001,2003 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -82,19 +83,22 @@ USA. (define-structure (source-node (conc-name source-node/) - (constructor make/source-node (filename))) - (filename false read-only true) - (pathname (->pathname filename) read-only true) + (constructor %make/source-node (filename pathname))) + (filename #f read-only #t) + (pathname #f read-only #t) (forward-links '()) (backward-links '()) (forward-closure '()) (backward-closure '()) (dependencies '()) (dependents '()) - (rank false) - (syntax-table false) + (rank #f) + (syntax-table #f) (declarations '()) - (modification-time false)) + (modification-time #f)) + +(define (make/source-node filename) + (%make/source-node filename (->pathname filename))) (define (filename->source-node filename) (let ((node (hash-table/get source-hash filename #f))) @@ -216,7 +220,7 @@ USA. (write-string " newer than dependency ") (write (source-node/filename node*)))) newer?)))) - (set-source-node/modification-time! node false)))) + (set-source-node/modification-time! node #f)))) source-nodes) (for-each (lambda (node) @@ -228,7 +232,7 @@ USA. (write (source-node/filename node*)) (write-string " depends on ") (write (source-node/filename node)))) - (set-source-node/modification-time! node* false)) + (set-source-node/modification-time! node* #f)) (source-node/forward-closure node)))) source-nodes))) (for-each (lambda (node) @@ -257,7 +261,7 @@ USA. (define (source-node/touch! node) (with-values (lambda () - (sf/pathname-defaulting (source-node/pathname node) "" false)) + (sf/pathname-defaulting (source-node/pathname node) "" #f)) (lambda (input-pathname bin-pathname spec-pathname) input-pathname (pathname-touch! bin-pathname) @@ -285,7 +289,7 @@ USA. (define (source-node/syntax! node) (with-values (lambda () - (sf/pathname-defaulting (source-node/pathname node) "" false)) + (sf/pathname-defaulting (source-node/pathname node) "" #f)) (lambda (input-pathname bin-pathname spec-pathname) (sf/internal input-pathname bin-pathname spec-pathname @@ -556,15 +560,15 @@ USA. `(INTEGRATE-EXTERNAL ,@(map (let ((default (make-pathname - false - false + #f + #f (cons 'RELATIVE (make-list (length (cdr (pathname-directory pathname))) 'UP)) - false - false - false))) + #f + #f + #f))) (lambda (pathname) (merge-pathnames pathname default))) integration-dependencies))) diff --git a/v7/src/compiler/machines/i386/decls.scm b/v7/src/compiler/machines/i386/decls.scm index f1b382e61..de9dba3e9 100644 --- a/v7/src/compiler/machines/i386/decls.scm +++ b/v7/src/compiler/machines/i386/decls.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: decls.scm,v 1.13 2003/02/14 18:28:03 cph Exp $ +$Id: decls.scm,v 1.14 2003/03/10 20:51:49 cph Exp $ -Copyright (c) 1992-2001 Massachusetts Institute of Technology +Copyright 1992,1993,2001,2003 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -82,19 +82,22 @@ USA. (define-structure (source-node (conc-name source-node/) - (constructor make/source-node (filename))) - (filename false read-only true) - (pathname (->pathname filename) read-only true) + (constructor %make/source-node (filename pathname))) + (filename #f read-only #t) + (pathname #f read-only #t) (forward-links '()) (backward-links '()) (forward-closure '()) (backward-closure '()) (dependencies '()) (dependents '()) - (rank false) - (syntax-table false) + (rank #f) + (syntax-table #f) (declarations '()) - (modification-time false)) + (modification-time #f)) + +(define (make/source-node filename) + (%make/source-node filename (->pathname filename))) (define (filename->source-node filename) (let ((node (hash-table/get source-hash filename #f))) @@ -221,7 +224,7 @@ USA. (write (source-node/filename node*)) (newline))) newer?)))) - (set-source-node/modification-time! node false)))) + (set-source-node/modification-time! node #f)))) source-nodes) (for-each (lambda (node) @@ -235,7 +238,7 @@ USA. (write-string " depends on ") (write (source-node/filename node)) (newline))) - (set-source-node/modification-time! node* false)) + (set-source-node/modification-time! node* #f)) (source-node/forward-closure node)))) source-nodes))) (for-each (lambda (node) @@ -270,7 +273,7 @@ USA. (define (source-node/touch! node) (with-values (lambda () - (sf/pathname-defaulting (source-node/pathname node) "" false)) + (sf/pathname-defaulting (source-node/pathname node) "" #f)) (lambda (input-pathname bin-pathname spec-pathname) input-pathname (pathname-touch! bin-pathname) @@ -302,7 +305,7 @@ USA. (define (source-node/syntax! node) (with-values (lambda () - (sf/pathname-defaulting (source-node/pathname node) "" false)) + (sf/pathname-defaulting (source-node/pathname node) "" #f)) (lambda (input-pathname bin-pathname spec-pathname) (sf/internal input-pathname bin-pathname spec-pathname @@ -575,15 +578,15 @@ USA. `(INTEGRATE-EXTERNAL ,@(map (let ((default (make-pathname - false - false + #f + #f (cons 'RELATIVE (make-list (length (cdr (pathname-directory pathname))) 'UP)) - false - false - false))) + #f + #f + #f))) (lambda (pathname) (merge-pathnames pathname default))) integration-dependencies))) diff --git a/v7/src/compiler/machines/mips/decls.scm b/v7/src/compiler/machines/mips/decls.scm index d687d9770..f8fb27be0 100644 --- a/v7/src/compiler/machines/mips/decls.scm +++ b/v7/src/compiler/machines/mips/decls.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: decls.scm,v 1.14 2003/02/14 18:28:03 cph Exp $ +$Id: decls.scm,v 1.15 2003/03/10 20:51:49 cph Exp $ -Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology +Copyright 1990,1991,1992,1993,2001,2003 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -82,19 +82,22 @@ USA. (define-structure (source-node (conc-name source-node/) - (constructor make/source-node (filename))) - (filename false read-only true) - (pathname (->pathname filename) read-only true) + (constructor %make/source-node (filename pathname))) + (filename #f read-only #t) + (pathname #f read-only #t) (forward-links '()) (backward-links '()) (forward-closure '()) (backward-closure '()) (dependencies '()) (dependents '()) - (rank false) - (syntax-table false) + (rank #f) + (syntax-table #f) (declarations '()) - (modification-time false)) + (modification-time #f)) + +(define (make/source-node filename) + (%make/source-node filename (->pathname filename))) (define (filename->source-node filename) (let ((node (hash-table/get source-hash filename #f))) @@ -216,7 +219,7 @@ USA. (write-string " newer than dependency ") (write (source-node/filename node*)))) newer?)))) - (set-source-node/modification-time! node false)))) + (set-source-node/modification-time! node #f)))) source-nodes) (for-each (lambda (node) @@ -228,7 +231,7 @@ USA. (write (source-node/filename node*)) (write-string " depends on ") (write (source-node/filename node)))) - (set-source-node/modification-time! node* false)) + (set-source-node/modification-time! node* #f)) (source-node/forward-closure node)))) source-nodes))) (for-each (lambda (node) @@ -257,7 +260,7 @@ USA. (define (source-node/touch! node) (with-values (lambda () - (sf/pathname-defaulting (source-node/pathname node) "" false)) + (sf/pathname-defaulting (source-node/pathname node) "" #f)) (lambda (input-pathname bin-pathname spec-pathname) input-pathname (pathname-touch! bin-pathname) @@ -285,7 +288,7 @@ USA. (define (source-node/syntax! node) (with-values (lambda () - (sf/pathname-defaulting (source-node/pathname node) "" false)) + (sf/pathname-defaulting (source-node/pathname node) "" #f)) (lambda (input-pathname bin-pathname spec-pathname) (sf/internal input-pathname bin-pathname spec-pathname @@ -557,15 +560,15 @@ USA. `(INTEGRATE-EXTERNAL ,@(map (let ((default (make-pathname - false - false + #f + #f (cons 'RELATIVE (make-list (length (cdr (pathname-directory pathname))) 'UP)) - false - false - false))) + #f + #f + #f))) (lambda (pathname) (merge-pathnames pathname default))) integration-dependencies))) diff --git a/v7/src/compiler/machines/sparc/decls.scm b/v7/src/compiler/machines/sparc/decls.scm index bdd2c669e..e65f036e6 100644 --- a/v7/src/compiler/machines/sparc/decls.scm +++ b/v7/src/compiler/machines/sparc/decls.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: decls.scm,v 1.8 2003/02/14 18:28:06 cph Exp $ +$Id: decls.scm,v 1.9 2003/03/10 20:51:49 cph Exp $ -Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology +Copyright 1993,2001,2003 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -79,19 +79,22 @@ USA. (define-structure (source-node (conc-name source-node/) - (constructor make/source-node (filename))) - (filename false read-only true) - (pathname (string->pathname filename) read-only true) + (constructor %make/source-node (filename pathname))) + (filename #f read-only #t) + (pathname #f read-only #t) (forward-links '()) (backward-links '()) (forward-closure '()) (backward-closure '()) (dependencies '()) (dependents '()) - (rank false) - (syntax-table false) + (rank #f) + (syntax-table #f) (declarations '()) - (modification-time false)) + (modification-time #f)) + +(define (make/source-node filename) + (%make/source-node filename (->pathname filename))) (define (filename->source-node filename) (let ((node (hash-table/get source-hash filename #f))) @@ -212,7 +215,7 @@ USA. (write-string " newer than dependency ") (write (source-node/filename node*)))) newer?)))) - (set-source-node/modification-time! node false)))) + (set-source-node/modification-time! node #f)))) source-nodes) (for-each (lambda (node) @@ -224,7 +227,7 @@ USA. (write (source-node/filename node*)) (write-string " depends on ") (write (source-node/filename node)))) - (set-source-node/modification-time! node* false)) + (set-source-node/modification-time! node* #f)) (source-node/forward-closure node)))) source-nodes))) (for-each (lambda (node) @@ -253,7 +256,7 @@ USA. (define (source-node/touch! node) (with-values (lambda () - (sf/pathname-defaulting (source-node/pathname node) "" false)) + (sf/pathname-defaulting (source-node/pathname node) "" #f)) (lambda (input-pathname bin-pathname spec-pathname) input-pathname (pathname-touch! bin-pathname) @@ -281,7 +284,7 @@ USA. (define (source-node/syntax! node) (with-values (lambda () - (sf/pathname-defaulting (source-node/pathname node) "" false)) + (sf/pathname-defaulting (source-node/pathname node) "" #f)) (lambda (input-pathname bin-pathname spec-pathname) (sf/internal input-pathname bin-pathname spec-pathname @@ -549,12 +552,12 @@ USA. `(INTEGRATE-EXTERNAL ,@(map (let ((default (make-pathname - false - false + #f + #f (make-list (length (pathname-directory pathname)) 'UP) - false - false - false))) + #f + #f + #f))) (lambda (pathname) (merge-pathnames pathname default))) integration-dependencies))) diff --git a/v7/src/compiler/machines/spectrum/decls.scm b/v7/src/compiler/machines/spectrum/decls.scm index f0aea546d..28e721b3a 100644 --- a/v7/src/compiler/machines/spectrum/decls.scm +++ b/v7/src/compiler/machines/spectrum/decls.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Id: decls.scm,v 4.39 2003/02/14 18:28:07 cph Exp $ +$Id: decls.scm,v 4.40 2003/03/10 20:51:49 cph Exp $ -Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology +Copyright 1990,1991,1992,1993,1994,2001 Massachusetts Institute of Technology +Copyright 2003 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -82,19 +83,22 @@ USA. (define-structure (source-node (conc-name source-node/) - (constructor make/source-node (filename))) - (filename false read-only true) - (pathname (->pathname filename) read-only true) + (constructor %make/source-node (filename pathname))) + (filename #f read-only #t) + (pathname #f read-only #t) (forward-links '()) (backward-links '()) (forward-closure '()) (backward-closure '()) (dependencies '()) (dependents '()) - (rank false) - (syntax-table false) + (rank #f) + (syntax-table #f) (declarations '()) - (modification-time false)) + (modification-time #f)) + +(define (make/source-node filename) + (%make/source-node filename (->pathname filename))) (define (filename->source-node filename) (let ((node (hash-table/get source-hash filename #f))) @@ -216,7 +220,7 @@ USA. (write-string " newer than dependency ") (write (source-node/filename node*)))) newer?)))) - (set-source-node/modification-time! node false)))) + (set-source-node/modification-time! node #f)))) source-nodes) (for-each (lambda (node) @@ -228,7 +232,7 @@ USA. (write (source-node/filename node*)) (write-string " depends on ") (write (source-node/filename node)))) - (set-source-node/modification-time! node* false)) + (set-source-node/modification-time! node* #f)) (source-node/forward-closure node)))) source-nodes))) (for-each (lambda (node) @@ -257,7 +261,7 @@ USA. (define (source-node/touch! node) (with-values (lambda () - (sf/pathname-defaulting (source-node/pathname node) "" false)) + (sf/pathname-defaulting (source-node/pathname node) "" #f)) (lambda (input-pathname bin-pathname spec-pathname) input-pathname (pathname-touch! bin-pathname) @@ -285,7 +289,7 @@ USA. (define (source-node/syntax! node) (with-values (lambda () - (sf/pathname-defaulting (source-node/pathname node) "" false)) + (sf/pathname-defaulting (source-node/pathname node) "" #f)) (lambda (input-pathname bin-pathname spec-pathname) (sf/internal input-pathname bin-pathname spec-pathname @@ -555,15 +559,15 @@ USA. `(INTEGRATE-EXTERNAL ,@(map (let ((default (make-pathname - false - false + #f + #f (cons 'RELATIVE (make-list (length (cdr (pathname-directory pathname))) 'UP)) - false - false - false))) + #f + #f + #f))) (lambda (pathname) (merge-pathnames pathname default))) integration-dependencies))) diff --git a/v7/src/compiler/machines/vax/decls.scm b/v7/src/compiler/machines/vax/decls.scm index 8598b01f3..021ea59ca 100644 --- a/v7/src/compiler/machines/vax/decls.scm +++ b/v7/src/compiler/machines/vax/decls.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Id: decls.scm,v 4.17 2003/02/14 18:28:07 cph Exp $ +$Id: decls.scm,v 4.18 2003/03/10 20:51:49 cph Exp $ -Copyright (c) 1987-1999, 2001 Massachusetts Institute of Technology +Copyright 1988,1989,1991,1992,1993,2001 Massachusetts Institute of Technology +Copyright 2003 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -82,19 +83,22 @@ USA. (define-structure (source-node (conc-name source-node/) - (constructor make/source-node (filename))) - (filename false read-only true) - (pathname (->pathname filename) read-only true) + (constructor %make/source-node (filename pathname))) + (filename #f read-only #t) + (pathname #f read-only #t) (forward-links '()) (backward-links '()) (forward-closure '()) (backward-closure '()) (dependencies '()) (dependents '()) - (rank false) - (syntax-table false) + (rank #f) + (syntax-table #f) (declarations '()) - (modification-time false)) + (modification-time #f)) + +(define (make/source-node filename) + (%make/source-node filename (->pathname filename))) (define (filename->source-node filename) (let ((node (hash-table/get source-hash filename #f))) @@ -216,7 +220,7 @@ USA. (write-string " newer than dependency ") (write (source-node/filename node*)))) newer?)))) - (set-source-node/modification-time! node false)))) + (set-source-node/modification-time! node #f)))) source-nodes) (for-each (lambda (node) @@ -228,7 +232,7 @@ USA. (write (source-node/filename node*)) (write-string " depends on ") (write (source-node/filename node)))) - (set-source-node/modification-time! node* false)) + (set-source-node/modification-time! node* #f)) (source-node/forward-closure node)))) source-nodes))) (for-each (lambda (node) @@ -257,7 +261,7 @@ USA. (define (source-node/touch! node) (with-values (lambda () - (sf/pathname-defaulting (source-node/pathname node) "" false)) + (sf/pathname-defaulting (source-node/pathname node) "" #f)) (lambda (input-pathname bin-pathname spec-pathname) input-pathname (pathname-touch! bin-pathname) @@ -285,7 +289,7 @@ USA. (define (source-node/syntax! node) (with-values (lambda () - (sf/pathname-defaulting (source-node/pathname node) "" false)) + (sf/pathname-defaulting (source-node/pathname node) "" #f)) (lambda (input-pathname bin-pathname spec-pathname) (sf/internal input-pathname bin-pathname spec-pathname @@ -558,15 +562,15 @@ USA. `(INTEGRATE-EXTERNAL ,@(map (let ((default (make-pathname - false - false + #f + #f (cons 'RELATIVE (make-list (length (cdr (pathname-directory pathname))) 'UP)) - false - false - false))) + #f + #f + #f))) (lambda (pathname) (merge-pathnames pathname default))) integration-dependencies))) diff --git a/v7/src/imail/imail-util.scm b/v7/src/imail/imail-util.scm index fafc36a23..d93a8c26c 100644 --- a/v7/src/imail/imail-util.scm +++ b/v7/src/imail/imail-util.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: imail-util.scm,v 1.42 2003/02/14 18:28:14 cph Exp $ +$Id: imail-util.scm,v 1.43 2003/03/10 20:53:51 cph Exp $ -Copyright 1999-2001 Massachusetts Institute of Technology +Copyright 2000,2001,2003 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -431,18 +431,19 @@ USA. (define (open-xstring-input-port xstring position) (if (not (<= 0 position (external-string-length xstring))) (error:bad-range-argument position 'OPEN-XSTRING-INPUT-PORT)) - (let ((state (make-xstring-input-state xstring position))) + (let ((state (make-xstring-input-state xstring position position position))) (read-xstring-buffer state) (make-port xstring-input-type state))) (define-structure (xstring-input-state - (constructor make-xstring-input-state (xstring position)) + (constructor make-xstring-input-state + (xstring position buffer-start buffer-end)) (conc-name xstring-input-state/)) xstring position (buffer (make-string 65536) read-only #t) - (buffer-start position) - (buffer-end position)) + buffer-start + buffer-end) (define (xstring-port/xstring port) (xstring-input-state/xstring (port/state port))) diff --git a/v7/src/runtime/error.scm b/v7/src/runtime/error.scm index 26e0f0685..8352bea62 100644 --- a/v7/src/runtime/error.scm +++ b/v7/src/runtime/error.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: error.scm,v 14.61 2003/02/14 18:28:32 cph Exp $ +$Id: error.scm,v 14.62 2003/03/10 20:53:34 cph Exp $ Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology Copyright 1992,1993,1995,2000,2001,2002 Massachusetts Institute of Technology @@ -144,7 +144,8 @@ USA. (define-structure (condition (conc-name %condition/) - (constructor %make-condition (type continuation restarts)) + (constructor %%make-condition + (type continuation restarts field-values)) (print-procedure (standard-unparser-method 'CONDITION (lambda (condition port) @@ -155,10 +156,13 @@ USA. (type #f read-only #t) (continuation #f read-only #t) (restarts #f read-only #t) - (field-values (make-vector (%condition-type/number-of-fields type) #f) - read-only #t) + (field-values #f read-only #t) (properties (make-1d-table) read-only #t)) +(define (%make-condition type continuation restarts) + (%%make-condition type continuation restarts + (make-vector (%condition-type/number-of-fields type) #f))) + (define (make-condition type continuation restarts field-alist) (guarantee-condition-type type 'MAKE-CONDITION) (guarantee-continuation continuation 'MAKE-CONDITION) diff --git a/v7/src/runtime/generic.scm b/v7/src/runtime/generic.scm index ab308828e..2db120cef 100644 --- a/v7/src/runtime/generic.scm +++ b/v7/src/runtime/generic.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: generic.scm,v 1.5 2003/02/14 18:28:32 cph Exp $ +$Id: generic.scm,v 1.6 2003/03/10 20:53:34 cph Exp $ -Copyright 1995-1999 Massachusetts Institute of Technology +Copyright 1996,2003 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -55,7 +55,11 @@ USA. (car arity) arity) generator - name))) + name + (new-cache + (if (pair? arity) + (car arity) + arity))))) (let ((generic (compute-apply-generic record))) (set-generic-record/procedure! record generic) (eqht/put! generic-procedure-records generic record) @@ -64,12 +68,12 @@ USA. (define-structure (generic-record (conc-name generic-record/) (constructor make-generic-record - (tag arity generator name))) + (tag arity generator name cache))) (tag #f read-only #t) (arity #f read-only #t) (generator #f) (name #f read-only #t) - (cache (new-cache (if (pair? arity) (car arity) arity))) + cache procedure) (define (generic-record/min-arity record) diff --git a/v7/src/runtime/infstr.scm b/v7/src/runtime/infstr.scm index 6359aa9f7..a70c22777 100644 --- a/v7/src/runtime/infstr.scm +++ b/v7/src/runtime/infstr.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Id: infstr.scm,v 1.17 2003/02/14 18:28:32 cph Exp $ +$Id: infstr.scm,v 1.18 2003/03/10 20:53:34 cph Exp $ -Copyright (c) 1988-2002 Massachusetts Institute of Technology +Copyright 1988,1989,1990,1991,1992,2001 Massachusetts Institute of Technology +Copyright 2002,2003 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -170,74 +171,14 @@ USA. (dbg-block-name normal-closure) (dbg-block-name return-address) (dbg-block-name static-link)) - -(define (dbg-label/name label) - (cond ((dbg-label-2? label) (dbg-label-2/name label)) - ((dbg-label-1? label) (dbg-label-1/name label)) - (else - (error:wrong-type-argument label "debugging label" 'DBG-LABEL/NAME)))) - -(define (set-dbg-label/name! label name) - (cond ((dbg-label-1? label) (set-dbg-label-1/name! label name)) - (else - (error:wrong-type-argument label "debugging label" - 'SET-DBG-LABEL/NAME!)))) - -(define (dbg-label/offset label) - (cond ((dbg-label-2? label) (dbg-label-2/offset label)) - ((dbg-label-1? label) (dbg-label-1/offset label)) - (else - (error:wrong-type-argument label "debugging label" - 'DBG-LABEL/OFFSET)))) - -(define (dbg-label/external? label) - (cond ((dbg-label-2? label) (dbg-label-2/external? label)) - ((dbg-label-1? label) (dbg-label-1/external? label)) - (else - (error:wrong-type-argument label "debugging label" - 'DBG-LABEL/EXTERNAL?)))) - -(define (set-dbg-label/external?! label external?) - (cond ((dbg-label-2? label) (set-dbg-label-2/external?! label external?)) - ((dbg-label-1? label) (set-dbg-label-1/external?! label external?)) - (else - (error:wrong-type-argument label "debugging label" - 'SET-DBG-LABEL/EXTERNAL?!)))) - -(define (dbg-label/names label) - (cond ((dbg-label-2? label) (dbg-label-2/names label)) - ((dbg-label-1? label) (dbg-label-1/names label)) - (else - (error:wrong-type-argument label "debugging label" - 'DBG-LABEL/NAMES)))) - -(define (set-dbg-label/names! label names) - (cond ((dbg-label-1? label) (set-dbg-label-1/names! label names)) - (else - (error:wrong-type-argument label "debugging label" - 'SET-DBG-LABEL/NAMES!)))) - -(define-structure (dbg-label-1 - (type vector) - (named - ((ucode-primitive string->symbol) - "#[(runtime compiler-info)dbg-label]")) - (constructor make-dbg-label (name offset)) - (conc-name dbg-label-1/)) - (name #f) ;a string, primary name - (offset #f read-only #t) ;mach. dependent offset into code block - (external? #f) ;if true, can have pointer to this - (names (list name)) ;names of all labels at this offset - ) (define-integrable make-dbg-label-2 cons) -(define-integrable dbg-label-2? pair?) -(define-integrable dbg-label-2/name car) -(define-integrable (dbg-label-2/offset label) (abs (cdr label))) -(define-integrable (dbg-label-2/external? label) (negative? (cdr label))) -(define-integrable (dbg-label-2/names label) (list (car label))) +(define-integrable dbg-label/name car) +(define-integrable (dbg-label/offset label) (abs (cdr label))) +(define-integrable (dbg-label/external? label) (negative? (cdr label))) +(define-integrable (dbg-label/names label) (list (car label))) -(define (set-dbg-label-2/external?! label external?) +(define (set-dbg-label/external?! label external?) (let ((offset (cdr label))) (if (if external? (not (negative? offset)) diff --git a/v7/src/runtime/os2graph.scm b/v7/src/runtime/os2graph.scm index 033d677c6..8f628e4a1 100644 --- a/v7/src/runtime/os2graph.scm +++ b/v7/src/runtime/os2graph.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: os2graph.scm,v 1.22 2003/02/14 18:28:33 cph Exp $ +$Id: os2graph.scm,v 1.23 2003/03/10 20:53:34 cph Exp $ Copyright 1995,1996,1997,1999,2000 Massachusetts Institute of Technology Copyright 2001,2002,2003 Massachusetts Institute of Technology @@ -133,7 +133,8 @@ USA. (define-structure (window (conc-name window/) - (constructor %make-window (wid pel-width pel-height))) + (constructor %make-window + (wid pel-width pel-height x-slope y-slope))) wid pel-width pel-height @@ -145,8 +146,8 @@ USA. (y-bottom -1) (x-right 1) (y-top 1) - (x-slope (exact->inexact (/ (- pel-width 1) 2))) - (y-slope (exact->inexact (/ (- pel-height 1) 2))) + x-slope + y-slope font-specifier font-metrics (foreground-color #xFFFFFF) @@ -154,7 +155,10 @@ USA. device) (define (make-window wid width height) - (let ((window (%make-window wid width height))) + (let ((window + (%make-window wid width height + (exact->inexact (/ (- width 1) 2)) + (exact->inexact (/ (- height 1) 2))))) (set-window/backing-image! window (create-image width height)) (add-to-gc-finalizer! window-finalizer window wid) window)) diff --git a/v7/src/runtime/process.scm b/v7/src/runtime/process.scm index d83128731..e4ece6579 100644 --- a/v7/src/runtime/process.scm +++ b/v7/src/runtime/process.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Id: process.scm,v 1.28 2003/02/14 18:28:33 cph Exp $ +$Id: process.scm,v 1.29 2003/03/10 20:53:34 cph Exp $ -Copyright (c) 1989-2000 Massachusetts Institute of Technology +Copyright 1990,1991,1992,1995,1997,1998 Massachusetts Institute of Technology +Copyright 1999,2000,2003 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -53,7 +54,7 @@ USA. (define-structure (subprocess (constructor %make-subprocess (filename arguments index pty-master - input-channel output-channel)) + input-channel output-channel id)) (conc-name subprocess-)) (filename #f read-only #t) (arguments #f read-only #t) @@ -61,7 +62,7 @@ USA. pty-master input-channel output-channel - (id ((ucode-primitive process-id 1) index) read-only #t) + (id #f read-only #t) (%i/o-port #f) (%status #f) (exit-reason #f) @@ -183,8 +184,10 @@ USA. working-directory ctty stdin stdout stderr))) (let ((process - (%make-subprocess filename arguments index pty-master - input-channel output-channel))) + (%make-subprocess + filename arguments index pty-master + input-channel output-channel + ((ucode-primitive process-id 1) index)))) (set-subprocess-%status! process ((ucode-primitive process-status 1) index)) diff --git a/v7/src/runtime/ystep.scm b/v7/src/runtime/ystep.scm index 9168fedbe..63e5f77b7 100644 --- a/v7/src/runtime/ystep.scm +++ b/v7/src/runtime/ystep.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: ystep.scm,v 1.5 2003/02/14 18:28:34 cph Exp $ +$Id: ystep.scm,v 1.6 2003/03/10 20:53:34 cph Exp $ -Copyright (c) 1994, 1999 Massachusetts Institute of Technology +Copyright 1994,1997,2003 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -288,15 +288,16 @@ USA. ;;;; Stepper nodes -(define-structure (ynode (constructor make-ynode-1 (parent type exp))) +(define-structure (ynode + (constructor make-ynode-1 + (parent type exp redisplay-flags))) ;; Could easily store environment as well. parent type (exp #f read-only #t) (children '()) (result #f) - (redisplay-flags (cons #t (if parent (ynode-redisplay-flags parent) '())) - read-only #t)) + (redisplay-flags #f read-only #t)) (define ynode-exp:top-level (list 'STEPPER-TOP-LEVEL)) (define ynode-exp:proceed (list 'STEPPER-PROCEED)) @@ -322,7 +323,10 @@ USA. (eq? (ynode-result node) ynode-result:reduced)) (define (make-ynode parent type exp) - (let ((node (make-ynode-1 parent type exp))) + (let ((node + (make-ynode-1 parent type exp + (cons #t + (if parent (ynode-redisplay-flags parent) '()))))) (set-ynode-result! node ynode-result:waiting) (if parent (set-ynode-children! parent (cons node (ynode-children parent)))) @@ -331,22 +335,19 @@ USA. (define (ynode-previous node) (let loop ((sibs (ynode-children (ynode-parent node)))) - (cond ((null? sibs) - #f) - ((eq? (car sibs) node) - (and (not (null? (cdr sibs))) - (cadr sibs))) - (else - (loop (cdr sibs)))))) + (and (pair? sibs) + (if (eq? (car sibs) node) + (and (pair? (cdr sibs)) + (cadr sibs)) + (loop (cdr sibs)))))) (define (ynode-next node) (let loop ((sibs (ynode-children (ynode-parent node)))) - (cond ((or (null? sibs) (null? (cdr sibs))) - #f) - ((eq? (cadr sibs) node) - (car sibs)) - (else - (loop (cdr sibs)))))) + (and (pair? sibs) + (pair? (cdr sibs)) + (if (eq? (cadr sibs) node) + (car sibs) + (loop (cdr sibs)))))) (define (ynode-value-node node) (if (ynode-reduced? node)