From: Chris Hanson Date: Mon, 22 Oct 2001 19:17:22 +0000 (+0000) Subject: Update for style. X-Git-Tag: 20090517-FFI~2490 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f8b3fd444991edc5f21c5ddcb60adb6b27a686e9;p=mit-scheme.git Update for style. --- diff --git a/v7/src/compiler/base/blocks.scm b/v7/src/compiler/base/blocks.scm index bb6188c44..d58829249 100644 --- a/v7/src/compiler/base/blocks.scm +++ b/v7/src/compiler/base/blocks.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: blocks.scm,v 4.14 1999/01/02 06:06:43 cph Exp $ +$Id: blocks.scm,v 4.15 2001/10/22 19:17:22 cph Exp $ -Copyright (c) 1988, 1989, 1990, 1999 Massachusetts Institute of Technology +Copyright (c) 1988-1990, 1999, 2001 Massachusetts Institute of Technology This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -16,14 +16,15 @@ General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software -Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. |# ;;;; Environment model data structures ;;; package: (compiler) (declare (usual-integrations)) - + #| Interpreter compatible (hereafter, IC) blocks are vectors with an @@ -92,8 +93,8 @@ from the continuation, and then "glued" into place afterwards. (define (make-block parent type) (let ((block (make-rvalue block-tag (enumeration/name->index block-types type) - parent '() '() false false '()'() '() '() '() '() '() - false false 'UNKNOWN 'UNKNOWN 'UNKNOWN false))) + parent '() '() #f #f '()'() '() '() '() '() '() + #f #f 'UNKNOWN 'UNKNOWN 'UNKNOWN #f))) (if parent (set-block-children! parent (cons block (block-children parent)))) (set! *blocks* (cons block *blocks*)) @@ -182,11 +183,10 @@ from the continuation, and then "glued" into place afterwards. (block-ancestor? block block*))) (define (block-ancestor? block block*) - (define (loop block) + (let loop ((block (block-parent block))) (and block (or (eq? block block*) - (loop (block-parent block))))) - (loop (block-parent block))) + (loop (block-parent block)))))) (define-integrable (block-child? block block*) (eq? block (block-parent block*))) @@ -197,11 +197,11 @@ from the continuation, and then "glued" into place afterwards. (define (block-nearest-common-ancestor block block*) (let loop - ((join false) + ((join #f) (ancestry (block-ancestry block)) (ancestry* (block-ancestry block*))) - (if (and (not (null? ancestry)) - (not (null? ancestry*)) + (if (and (pair? ancestry) + (pair? ancestry*) (eq? (car ancestry) (car ancestry*))) (loop (car ancestry) (cdr ancestry) (cdr ancestry*)) join))) @@ -210,8 +210,8 @@ from the continuation, and then "glued" into place afterwards. (let loop ((ancestry (block-ancestry block)) (ancestry* (block-ancestry block*))) - (and (not (null? ancestry)) - (if (and (not (null? ancestry*)) + (and (pair? ancestry) + (if (and (pair? ancestry*) (eq? (car ancestry) (car ancestry*))) (loop (cdr ancestry) (cdr ancestry*)) (car ancestry))))) @@ -236,7 +236,7 @@ from the continuation, and then "glued" into place afterwards. (if (block-parent block) (find-outermost-block (block-parent block)) block)) - + (define (stack-block/external-ancestor block) (let ((parent (block-parent block))) (if (and parent (stack-block? parent)) @@ -254,7 +254,7 @@ from the continuation, and then "glued" into place afterwards. n (loop (block-parent block) (+ n (block-frame-size block)))))) - + (define (for-each-block-descendant! block procedure) (let loop ((block block)) (procedure block) @@ -287,29 +287,7 @@ from the continuation, and then "glued" into place afterwards. (rvalue/procedure? procedure) (procedure-target-block procedure)))) -#| -(define (disown-block-child! block child) - (set-block-children! block (delq! child (block-children block))) - (if (eq? block (original-block-parent child)) - (set-block-disowned-children! block - (cons child (block-disowned-children block)))) - unspecific) - -(define (own-block-child! block child) - (set-block-parent! child block) - (set-block-children! block (cons child (block-children block))) - (if (eq? block (original-block-parent child)) - (set-block-disowned-children! block - (delq! child (block-disowned-children block)))) - unspecific) -|# - (define (transfer-block-child! child block block*) - ;; equivalent to - ;; (begin - ;; (disown-block-child! block child) - ;; (own-block-child! block* child)) - ;; but faster. (let ((original-parent (original-block-parent child))) (set-block-children! block (delq! child (block-children block))) (if (eq? block original-parent) @@ -341,7 +319,7 @@ from the continuation, and then "glued" into place afterwards. (block-entry-number block))))) (define (block-nearest-closure-ancestor block) - (let loop ((block block) (last false)) + (let loop ((block block) (last #f)) (and block (if (stack-block? block) (loop (block-parent block) block) diff --git a/v7/src/compiler/base/lvalue.scm b/v7/src/compiler/base/lvalue.scm index 32f4e1972..4f8a9e636 100644 --- a/v7/src/compiler/base/lvalue.scm +++ b/v7/src/compiler/base/lvalue.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: lvalue.scm,v 4.21 1999/01/02 06:06:43 cph Exp $ +$Id: lvalue.scm,v 4.22 2001/10/22 19:10:20 cph Exp $ -Copyright (c) 1988-1999 Massachusetts Institute of Technology +Copyright (c) 1988-1990, 1999, 2001 Massachusetts Institute of Technology This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -16,13 +16,15 @@ General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software -Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. |# ;;;; Left (Hand Side) Values +;;; package: (compiler) (declare (usual-integrations)) - + ;; IMPORTANT: Change transform/make-lvalue and the call to ;; define-type-definition in macros.scm whenever a field is added or ;; deleted! @@ -52,8 +54,8 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ;;; (define (make-lvalue tag . extra) ;;; (let ((lvalue ;;; (list->vector -;;; (cons* tag false '() '() '() '() '() '() 'NOT-CACHED -;;; false '() false false '() extra)))) +;;; (cons* tag #f '() '() '() '() '() '() 'NOT-CACHED +;;; #f '() #f #f '() extra)))) ;;; (set! *lvalues* (cons lvalue *lvalues*)) ;;; lvalue)) @@ -81,8 +83,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (define set-continuation-variable/type! set-variable-in-cell?!) (define (make-variable block name) - (make-lvalue variable-tag block name '() false false '() false false - false false false)) + (make-lvalue variable-tag block name '() #f #f '() #f #f #f #f #f)) (define variable-assoc (association-procedure eq? variable-name)) @@ -250,15 +251,15 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (if (stack-block? block) (let ((procedure (block-procedure block))) (cond ((procedure-always-known-operator? procedure) - true) + #t) ((or (memq lvalue (cdr (procedure-required procedure))) (memq lvalue (procedure-optional procedure)) (eq? lvalue (procedure-rest procedure))) - false) - (else true))) - true)) - true)))) + #f) + (else #t))) + #t)) + #t)))) (define (variable-unused? variable) (or (lvalue-integrated? variable) @@ -271,7 +272,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (define (lvalue/unique-source lvalue) (let ((source-set (lvalue/source-set lvalue))) - (and (not (null? source-set)) + (and (pair? source-set) (null? (cdr source-set)) (car source-set)))) @@ -315,57 +316,4 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ;; is the outermost IC block of the expression in ;; which the variable is referenced. (memq variable - (block-bound-variables reference-block)))))))) - -;; This is not in use anywhere! What is it for? -- Arthur & GJR 1/93 - -#| - -(define (lvalue/articulation-points lvalue) - ;; This won't work if (memq lvalue (lvalue-backward-links lvalue))? - (let ((articulation-points '()) - (number-tag "number-tag")) - (let ((articulation-point! - (lambda (lvalue) - (if (not (memq lvalue articulation-points)) - (begin - (set! articulation-points (cons lvalue articulation-points)) - unspecific)))) - (allocate-number! - (let ((n 0)) - (lambda () - (let ((number n)) - (set! n (1+ n)) - number))))) - (with-new-lvalue-marks - (lambda () - (let loop ((lvalue lvalue) (parent false) (number (allocate-number!))) - (lvalue-mark! lvalue) - (lvalue-put! lvalue number-tag number) - (if (lvalue/source? lvalue) - number - (apply min - (cons number - (map (lambda (link) - (cond ((not (lvalue-marked? link)) - (let ((low - (loop link - lvalue - (allocate-number!)))) - (if (<= number low) - (articulation-point! lvalue)) - low)) - ((eq? link parent) - number) - (else - (lvalue-get link number-tag)))) - (lvalue-initial-backward-links lvalue))))))))) - (set! articulation-points - (sort (delq! lvalue articulation-points) - (lambda (x y) - (< (lvalue-get x number-tag) (lvalue-get y number-tag))))) - (for-each (lambda (lvalue) (lvalue-remove! lvalue number-tag)) - (cons lvalue (lvalue-backward-links lvalue))) - articulation-points)) - -|# \ No newline at end of file + (block-bound-variables reference-block)))))))) \ No newline at end of file diff --git a/v7/src/compiler/base/proced.scm b/v7/src/compiler/base/proced.scm index 357dd1e0d..77761194b 100644 --- a/v7/src/compiler/base/proced.scm +++ b/v7/src/compiler/base/proced.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: proced.scm,v 4.21 2001/10/22 19:04:50 cph Exp $ +$Id: proced.scm,v 4.22 2001/10/22 19:10:46 cph Exp $ Copyright (c) 1988-1990, 1999, 2001 Massachusetts Institute of Technology @@ -24,7 +24,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;;; package: (compiler) (declare (usual-integrations)) - + (define-rvalue procedure type ;either PROCEDURE or a continuation type block ;model of invocation environment [block] @@ -124,7 +124,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let ((number-required (length (procedure-required procedure)))) (and (>= argument-count number-required) (if (procedure-rest procedure) - true + #t (<= argument-count (+ number-required (length (procedure-optional procedure)))))))) diff --git a/v7/src/compiler/base/rvalue.scm b/v7/src/compiler/base/rvalue.scm index 7f97c8b50..6d0d9a0dc 100644 --- a/v7/src/compiler/base/rvalue.scm +++ b/v7/src/compiler/base/rvalue.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: rvalue.scm,v 4.7 1999/01/02 06:06:43 cph Exp $ +$Id: rvalue.scm,v 4.8 2001/10/22 19:13:04 cph Exp $ -Copyright (c) 1988, 1989, 1999 Massachusetts Institute of Technology +Copyright (c) 1988-1989, 1999, 2001 Massachusetts Institute of Technology This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -16,10 +16,12 @@ General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software -Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. |# ;;;; Right (Hand Side) Values +;;; package: (compiler) (declare (usual-integrations)) @@ -28,7 +30,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ;;; converted to a macro. ;;; (define (make-rvalue tag . extra) -;;; (list->vector (cons* tag false extra))) +;;; (list->vector (cons* tag #f extra))) (define-enumeration rvalue-type (block @@ -73,7 +75,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (if (rvalue/reference? rvalue*) (eq? rvalue (lvalue-known-value (reference-lvalue rvalue*))) (eq? rvalue rvalue*)))) - + ;;;; Constant (define-rvalue constant @@ -130,7 +132,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (define (reference-to-known-location? reference) (variable-in-known-location? (reference-context reference) (reference-lvalue reference))) - + ;;; This type is only important while we use the `unassigned?' special ;;; form to perform optional argument defaulting. When we switch over ;;; to the new optional argument proposal we can flush this since the @@ -150,7 +152,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (define-integrable (rvalue/unassigned-test? rvalue) (eq? (tagged-vector/tag rvalue) unassigned-test-tag)) - + ;;;; Expression (define-rvalue expression @@ -166,7 +168,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (let ((expression (make-rvalue expression-tag block continuation (node->edge (cfg-entry-node scfg)) - (generate-label 'EXPRESSION) false))) + (generate-label 'EXPRESSION) #f))) (set! *expressions* (cons expression *expressions*)) (set-block-procedure! block expression) expression))