#| -*-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.
\f
;;;; 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)
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)
#| -*-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.
\f
(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)))
(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)
(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)
(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)
(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
`(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)))
#| -*-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.
\f
(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)))
(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)
(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)
(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)
(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
`(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)))
#| -*-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.
\f
(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)))
(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)
(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)
(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)
(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
`(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)))
#| -*-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.
\f
(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)))
(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)
(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)
(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)
(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
`(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)))
#| -*-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.
\f
(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)))
(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)
(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)
(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)
(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
`(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)))
#| -*-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.
\f
(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)))
(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)
(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)
(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)
(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
`(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)))
#| -*-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.
\f
(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)))
(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)
(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)
(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)
(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
`(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)))
#| -*-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.
\f
(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)))
(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)
(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)
(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)
(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
`(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)))
#| -*-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.
(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)))
#| -*-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
(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)
(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)
#| -*-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.
(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)
(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)
#| -*-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.
(dbg-block-name normal-closure)
(dbg-block-name return-address)
(dbg-block-name static-link))
-\f
-(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))
#| -*-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
(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
(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)
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))
#| -*-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.
(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)
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)
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))
#| -*-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.
\f
;;;; 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))
(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))))
(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)
projects / mit-scheme.git / commitdiff